Перенос данных по условию в excel используя макрос

Не редко возникает ситуация, когда необходимо перенести данные из одной таблицы в соответствующие ячейки другой. Как говорится, ничего сложного, когда таких данных мало. В противном случае - это проблематично. А если это нужно делать регулярно, несколько раз в неделю, то сильно напрягает и отнимает уйму времени.

Так и в моем случае, мне понадобилось еженедельно отслеживать позиции своего сайта planero.ru по определенным ключевым словам. И если съем позиций сайта в выдаче Яндекса я осуществляю с помощью небезызвестного Key Collector в автоматическом режиме, результатом работы которого получается экселевский файл следующего вида:

съем позиций через key collector
Результат key collerctor’а

В общем, результат работы key collector’а представляет из себя массив данных, который не дает конкретного представления о ситуации в целом. Картину целиком можно увидеть в другой таблице, уже созданной мной, где отражена сама статья с ее продвигаемыми ключевыми словами и позиции, на которых находится мой сайт на дату «02.06.2020». На итог необходимо, при нажатии на кнопку «Заполнить позиции страниц в выдаче», автоматически перенести данные из таблицы key collector’а в мою таблицу, напротив соответствующих ключей, при этом нужно добавить новый столбец с датой съема позиций, а также выделить цветом позиции, которые просели (красным), либо наоборот поднялись (зеленым).

Полностью рабочий вариант макроса переноса данных по условию с одной таблицы в другую можно скачать архивом или же изучить статью и написать самостоятельно, будет полезнее.

статьи с ключевыми словами
наглядное представление позиций ключевых слов

Ну что ж, начнем воплощать в жизнь идею по автоматизации рутинной работы. И начнем с составления формы, которая будет появляться при нажатии на кнопку «Заполнить позиции страниц в выдаче» для выбора экселевского файла кей коллектора и даты съема позиций.

форма выбора данных
выбор файла экспорта кей коллектора и даты съема

После напишем процедуру вызова UserForm1 на листе «Статьи» при нажатии на соответствующую кнопку. Процедура должна автоматически предоставлять данные по всем открытым книгам Эксель, записывать текущую дату и выравнивать форму по центру экрана. Код процедуры выглядит следующим образом:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' показать UserForm1 прин нажатии на кнопку "Заполнить позиции страниц в выдаче"
If ActiveCell.Column = 9 And Cells(ActiveCell.Row, ActiveCell.Column).Value = "Заполнить позиции страниц в выдаче" And ActiveCell.Row = 2 Then
' ищем все открытые книги экселя
Dim wb As Workbook
For Each wb In Workbooks
With UserForm1.ComboBox1
.AddItem wb.Name' добавляем наименование книги экселя в ComboBox1
End With
Next
' выбираем последнюю найденную книгу в ComboBox1
UserForm1.ComboBox1.ListIndex = UserForm1.ComboBox1.ListCount - 1
' размещаем UserForm1 по центру экрана как по вертикали так и по горизонтали
UserForm1.Left = maxWidth / 2
UserForm1.Left = maxHeight / 2
' автоматически добавляем текущую дату в TextBox1 (т.к. раз нажали сегодня эту кнопку, соответственно и съем позиций был также сегодня. Поэтому зачем лишний раз пользователю лишний раз тратить свое драгоценное время даже на ввод текущей даты?)
UserForm1.TextBox1.Value = Format(Date, "dd.mm.yyyy")
' отображаем UserForm1
UserForm1.Show
' перемещаем курсор на A1 с кнопки
Workbooks("GTD planero.ru.xlsm").Worksheets("Статьи").Range("A1").Select
End If
End Sub

Теперь при нажатии на кнопку «Заполнить …» появится форма:

заполненная форма выбора данных
автоматически заполненная форма данных

Теперь напишем макрос для кнопки «Ок» UserForm1 проверяющий правильность выбора файла excel, т.е. наличия в нем необходимых ключевых фраз и в случае некорректного выбора, информирование пользователя с последующим выбором другого файла.

' процедура кнопки "Ok" UserForm1
Private Sub CommandButton1_Click()
' скрываем Label3 (информацию об ошибке)
UserForm1.Label3.Visible = False

' получаем название выбранного файла эксель
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

И наконец, реализуем самую главную функцию fpoz, которая будет осуществлять сравнение данных двух таблиц, заполнение необходимых строк и выделение цветом соответствующих ячеек. Вкратце сам принцип работы функции выглядит следующим образом:

  1. Ищем в шапке таблицы выбранную дату.
  2. Добавляем новый столбец c его соответствующим форматированием (в случае если даты выбранной в UserForm1 нет в шапке таблицы).
  3. Записываем продвигаемые фразы из нашей таблицы в массив.
  4. Находим в файле key collector’а столбец с наименованием «Фраза» и столбце с наименованием «Позиция [Ya]».
  5. Записываем ключевые слова из файла key collector’а и столбцов «Фраза», «Позиция[Ya]» в соответствующие массивы.
  6. Сравниваем массивы между собой и при совпадении – записываем значение позиции в соответствующую ячейку нашей таблицы, при этом, в случае если предыдущее значение было больше текущего (позиция поднялась) – выделяем его зеленым. И, наоборот, при ухудшении позиции (просела) – красным.

Полностью реализованная функция приведена ниже:

' функция заполнения позиций с аргументами mydate - дата введенная в UserForm1, namefile - имя книги, выбранное в UserForm1
Function fpoz(mydate, namefile)
' ссылка на лист книги в которую необходимо занести данные
Set ps = Workbooks("GTD planero.ru.xlsm").Worksheets("Статьи")
' ссылка на первый лист книги из которой необходимо брать данные (файл key kollector'а
Set poz = Workbooks(namefile).Worksheets(1)

' проходим по странице "Статьи" книги "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

На итог получилась картина следующего вида:

таблица с автоматически перенесёнными данными
Итоговый вариант автоматического переноса данных

Теперь копирование позиций напротив соответствующего ключевого слова происходит автоматически, при этом сравниваются с предыдущими значениями этих же позиций, и выделяются цветом: красным – в случае проседания позиции, зеленым – в случае улучшения.

После реализации данного макроса, отпала необходимость каждый раз вручную или с использованием встроенных в эксель функций, например ВПР(), заниматься сопоставлением. Сейчас это делается автоматически в течение одной секунды, по нажатию кнопки «Заполнить позиции страниц в выдаче».

Поделись с друзьями:
Комментарии 2

Сергей Карпухин
15 сентября 2020 в 09:55
Спасибо, но я знал об этих методах верстки. Они помогут, если заменяемый текст не сильно отличается по длине и умещается в одной строке. У меня проблема с высотой линий. Получается, что нужно сделать в шаблоне таблицу с высотой ячейки в самом длинном тексте (в две строки и соответствовать положению заголовка), но затем подставляя короткий текст (в одну строку), мы получаем пробел по высоте. Существуют ли переопределения разрывов строк при замене текста более чем в одной строке? А может якорь для заголовка?
Руслан Степанов
09 сентября 2020 в 18:07
Спасибо вам за такую подробную и пошаговую инструкцию. Я, конечно, буду статью ещё перечитывать, потому что сразу все сложно уложить в голове. Я пока новичок в области работы с таблицами Эксель и постоянно путаюсь даже в простых на первый взгляд вещах. Многое не могу запомнить с первого раза. Эта уже не первая ваша статья, которую я читаю и использую в своей деятельности. Нужное дело делаете, спасибо вам большое
© планеро.ru