Добрый день на текущий момент использую вот такой макрос
Скрытый текст
Код
Sub ВыделитьДубликатыРазнымиЦветами()
On Error Resume Next
' массив цветов, используемых для заливки ячеек-дубликатов
Colors = Array(12900829)
Dim coll As New Collection, dupes As New Collection, _
cols As New Collection, ra As Range, cell As Range, n&
Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)
If Err Then Exit Sub
ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes
Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
Next cell
For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов
n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
Next
For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет
cell.Interior.Color = cols(CStr(cell.Value))
Next cell
Application.ScreenUpdating = True
End Sub
Оставил только 1 цвет специально. Но этот макрос выделяет только 100% совпадение. А мне нужно и приблизительное, например
Абзалов Д Ф
Абзалов Даян Фазыльянович 10.03.1939
Совпадают Инициалы.
Абышева Дилбара Дуишенбиковна 31.01.1985
Абышева Дилбара Дуйшенбековна 31.01.1985
Разница в Отчестве Й и И. (во вложении пример и пояснения)
Помогите доработать макрос. или может это можно сделать другими инструментами? В реальном файле более 200тыс строк. быстродействие не особо важно. даже если будет минут 15-20 сверять.
Попробовал сделать Fuzzylockup но почему то не получилось.