На днях поступила задача обработать/нормализовать данные в таблице "лидов". После регистрации с разных веб-сайтов стекаются данные подписчиков в разном формате. Очень часто для упрощения регистрации посетителей просят ввести Ф.И.О в одной строке поля. И это значение хранится в структурированном виде как 1 строка из множества в таблицах. Вам нужно разделить по разделителю "пробел" значения строки разнеся их на разные столбцы для удобства обработки. В 90% случаев никто не вводит свое отчество (это абсолютно нормально), но эту подстроку тоже надо как-то вычислять. В общем, будем считать, что мы воспользовались сводкой данных в таблицу Excel, а через функцию на вкладке "Данные
" -> "Текст по столбцам"
разбили строку на подстроки, получив 3 столбца (Фамилия, Имя, Отчество). И вот мы подошли к сути этой небольшой статьи - порядок следования Фамилии и Имени в массе случаев просто нарушен, а маркетинг четко использует в рассылках обращение по имени.
Нужно привести в порядок значения 2-х столбцов (Фамилия и Имя), а третий столбец с отчеством нас не волнует, т.к. никто его не использует в маркетинговых коммуникациях типа рассылок. Задача сводится к тому, чтобы перебрать значения столбца с именами (где их больше всего) и если там встретится что-то похожее на фамилию, то поменять местами со следующей ячейкой, т.к. там со 100% вероятностью будет Имя подписчика. Как правило, большинство фамилий имеют некий перечень окончаний, которые отсутствуют в имени, а значит дают нам право на идентификацию. Решение задачи было перенесено непосредственно в среду макросов Excel, т.к. таблица была именно в этом формате.
Привожу листинг кода, код не оптимизирован, можно значительно его упростить и сделать универсальным, но конкретно эту задачу надо было решить оперативно.
Sub ChangeLeadsName()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("LEADS-Sheet")
Dim cell As Range
Dim arrEnds() As String
arrEnds = Split("ов,ев,ич,ко,ак,ук,ян,ии", ",")
Dim firstName, checkEnd As String
Dim position, j, k As Integer
ws.Activate
k = 0
For Each cell In Range("L2:L1844") ' указываем диапазон обработки столбца с именами
firstName = cell.Value
For j = 0 To UBound(arrEnds) ' перебираем окончания слова
checkEnd = Right(firstName, 2)
position = InStr(firstName, arrEnds(j)) ' необязательная функция поиска подстроки окончания в строке, но изначально она была одна
' Проверяем условие, что подстрока найдена, значение в ячейке есть, и 2 последних символа совпадают с нашим массивом окончаний
If position > 0 And arrEnds(j) = checkEnd And Not IsEmpty(cell.Offset(0, 1).Value) Then
cell.Value = cell.Offset(0, 1).Value ' смело записываем значение из соседней ячейки в анализируемую
cell.Offset(0, 1).Value = firstName ' в соседнюю справа ячейку запишем анализируемую строку/ячейку
cell.Interior.Color = vbYellow ' подсветим на листе ячейку где применили условие
k = k + 1 ' посчитаем, сколько раз сработало условие и выведем для информации ниже.
End If
Next j
Next cell
MsgBox "Всего под обработку попало: " & k & " записей из таблицы", , "Результат обработки"
End Sub
Итак, что ✔️ может функция этого макроса:
- Достаточно быстро (~1 секунда на 2000 записей) проанализировать и поменять ячейки местами.
- Отформатировать(окрасить) те ячейки таблицы, где макрос внес изменения для упрощения визуального контроля исполненной задачи.
- Можно пополнить массив окончаний для более продвинутого анализа.
А чего ❌не может макрос:
- Всякий раз нужно указывать размер анализируемого столбца (Range).
- Анализирует только 2 символа в окончании.
И напоследок такой момент: использование достаточно распространённого окончания "-ий" не будет корректно работать, т.к. множество имен также имеют такое же окончание "Валерий, Дмитрий, Василий" и т.д. Отдельно потребуется совершенствование алгоритма для женских фамилий (анализ окончания с 3-мя последними буквами, например).
В результате я больше потратил времени на написание этой статьи, чем на написание макроса и, я уверен, что приведенный код можно значительно сократить и улучшить!
В любом случае придется вручную ячейки проверять и для тех значений, где нет условий описанного макроса, хорошо бы по сочетанию клавиш вызывать функцию обмена ("свопа") 2-х выделенных ячеек между собой. Для этого можно использовать такой макрос (нашел на просторах интернета, ссылку не помню):
Sub SwapTwoCells()
Dim temp As Variant
If Selection.Cells.Count = 2 Then
With Selection
temp = .Cells(1).Value ' Store the value of the first cell
.Cells(1).Value = .Cells(2).Value ' Assign the value of the second cell to the first
.Cells(2).Value = temp ' Assign the stored value to the second cell
End With
Else
MsgBox "Please select exactly two cells to swap", vbCritical
End If
End Sub
В параметрах макроса необходимо назначить сочетание "горячих клавиш" Ctrl+Латинская буква
. Пользоваться просто: выделяете 2 ячейки и нажимаете назначенное сочетание клавиш.
Удачной нормализации данных!