Макрос excel перенос значений

' получаем название выбранного файла эксель
namefile = UserForm1.ComboBox1.Value
' ссылка на первый лист выбранной книги
Set poz = Workbooks(namefile).Worksheets(1)
q = 0
' нашлась (1) или не нашлась (0) ячейка с наименованием "Фраза"
da = 0
' проходим по столбцам первой строки до тех пор пока в них есть данные
Do While poz.Range("A1").Offset(0, q) > 0
' если нашли столбец с наименованием "Фраза" присваиваем переменной da = 1 и выходим из цикла
If poz.Range("A1").Offset(0, q) = "Фраза" Then
da = 1
Exit Do
End If
q = q + 1
Loop

If da = 0 Then
' выводим предупреждение о некорректном выборе файла в случае не нахождения в нем ячейки с наименованием "Фраза"
With UserForm1.Label3
.Caption = "В выбранном файле нет данных по фразам и позициям. Выберите другой файл"
.Visible = True
End With
Else
' в случае если файл выбран верно - запускаем в работу функцию заполнения позиций fpoz с передачей ей выбранной даты и наименования файла в виде аргументов
a = Module1.fpoz(Date, namefile)
' скрываем форму UserForm1
Unload UserForm1
End If
End Sub

' проходим по странице "Статьи" книги "GTD planero.ru.xlsm" и ищем совпадения в дате или пустую ячейку в строке 4
i = 0 ' сколько отступить от ячейки J4
da = 0 ' 0 - нет совпадений; 1 - совпадение найдено
' запускаем цикл прохода вправа от ячейки J4 до тех пор пока есть данные или не найдено совпадение
Do While ps.Range("J4").Offset(0, i) > 0
' если нашлось совпадение по дате - присваиваем переменной da значение 1 и выходим из цикла
If ps.Range("J4").Offset(0, i) = mydate Then
da = 1
Exit Do
End If
' увеличиваем на 1 чтобы проверить следующую ячейку на равенство
i = i + 1
Loop
' если нет столбца с выбранной датой - добавляем новый
If da = 0 Then
i = 1
' добавляем новый столбец между столбцами J и K
Columns("K:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' записываем в шапку добавленного столбца выбранную в UserForm1 дату
ps.Range("J4").Offset(0, 1) = mydate
' форматируем шапку добавленного столбца в виде "01.01.20"
ps.Range("J4").Offset(0, 1).NumberFormat = "dd/mm/yy;@"
End If

' записываем в массив "Продвигаемые ключевые слова" из книги "GTD planero.ru.xlsm"
Dim arrKey() As String
j = 0
net = 0
' проходим по массиву до тех пор пока присутствуют ключевые слова, даже после их отсутствия 6 строк подряд
Do While ps.Range("I5").Offset(j, 0) > 0 Or net <= 6
' считаем пустые строки (чтобы при превышении 6 - выйти из цикла)
If ps.Range("I5").Offset(j, 0) <= 0 Then
net = net + 1
Else' если нашлось ключевое слово - обнуляем счетчик пустых строк
net = 0
End If
' изменяем размер массива arrKey до значения j
ReDim Preserve arrKey(j)
' записываем в массив ключевое слово, при этом заменяем "-" на " ", переводим все в строчные буквы, удаляем пробелвы в начале и конце ключевого слова
arrKey(j) = Replace(LCase(Trim(ps.Range("I5").Offset(j, 0))), "-", " ")
' увеличиваем счетчик на +1
j = j + 1
Loop

' в файле Съем позиций
' находим столбец "Фраза"
q = 0
' проходим по массиву до тех пор, пока не упремся в пустую ячейку
Do While poz.Range("A1").Offset(0, q) > 0
' если в шапке таблицы нашли столбец с наименованием "Фраза" - выходим из цикла
If poz.Range("A1").Offset(0, q) = "Фраза" Then
Exit Do
End If
q = q + 1
Loop
' находим столбец "Позиция [Ya]"
w = 0
' проходим по массиву до тех пор, пока не упремся в пустую ячейку
Do While poz.Range("A1").Offset(0, w) > 0
' если в шапке таблицы нашли столбец с наименованием "Позиция [Ya]" - выходим из цикла
If poz.Range("A1").Offset(0, w) = "Позиция [Ya]" Then
Exit Do
End If
w = w + 1
Loop
' создаем два массива: arrFraza для записи данных из столбца "Фраза", arrPoz для записи данных из столбца "Позиция [Ya]"
Dim arrFraza() As String
Dim arrPoz()
k = 0
' проходим по массиву до тех пор, пока не упремся в пустую ячейку
Do While poz.Range("A1").Offset(k, q) > 0
' изменяем размер обоих массивов до значения k
ReDim Preserve arrFraza(k)
ReDim Preserve arrPoz(k)
' записываем ключевое словои и его позицию в соответствующий массив
arrFraza(k) = poz.Range("A1").Offset(k, q)
arrPoz(k) = poz.Range("A1").Offset(k, w)
k = k + 1
Loop

' проходим по массивам - находим соответствия и записываем данные, выделяем их цветом в зависимости от предыдущих записей
h = 0
' проходим по массиву до тех пор, пока переменная h не превысит размер массива arrKey
Do While h <= UBound(arrKey)
l = 0
' проходим по массиву до тех пор, пока переменная l не превысит размер массива arrFraza
Do While l <= UBound(arrFraza)
' если значение обоих массивов совпадает
If arrKey(h) = arrFraza(l) Then
' если позиция меньше или равно нулю (т.е. отсутствует в поиске яндекса) - записываем в ячейку нашей таблицы "нет"
If arrPoz(l) <= 0 Then
ps.Range("J5").Offset(h, i) = "нет"
' если предыдущее значение > 0 и не равно "нет" - выделяем ячейку красным (показываем что позиция просела)
If ps.Range("J5").Offset(h, i + 1) > 0 And ps.Range("J5").Offset(h, i + 1) <> "нет" Then
ps.Range("J5").Offset(h, i).Interior.Color = 10987519
End If
' если позиция больше нуля
Else
' записываем значение в ячейку
ps.Range("J5").Offset(h, i) = arrPoz(l)
' если предыдущее значение равно "нет", т.е. его не было в выдаче - выделяем текущее значение зеленым (показываем что позиция поднялась)
If ps.Range("J5").Offset(h, i + 1) = "нет" Then
ps.Range("J5").Offset(h, i).Interior.Color = 11534247
' если предыдущее значение число
Else
' если текущая позиция < предыдущей позиции (т.е. выше в выдаче) - выделяем текущее значение зеленым (показываем что позиция поднялась)
If ps.Range("J5").Offset(h, i) < ps.Range("J5").Offset(h, i + 1) Then
ps.Range("J5").Offset(h, i).Interior.Color = 11534247
' если текущая позиция > или = предыдущей позиции
Else
' если текущая позиция > предыдущей позиции (т.е. ниже в выдаче) - выделяем текущее значение красным (показываем что позиция просела)
If ps.Range("J5").Offset(h, i) > ps.Range("J5").Offset(h, i + 1) Then
ps.Range("J5").Offset(h, i).Interior.Color = 10987519
End If
' если текущая позиция = предыдущей позиции (т.е. не изменилась) - ничего не делаем, оставляем ячейку безцветной
End If
End If
End If
End If
l = l + 1
Loop
h = h + 1
Loop
End Function