Прошу помочь мне с решением задачи. Есть скрипт, который в выделенном диапазоне подсвечивает дубликаты попарно:
Код
Sub DuplicatesColoring()
Dim Dupes() 'объявляем массив для хранения дубликатов
ReDim Dupes(1 To Selection.Cells.Count, 1 To 2)
Selection.Interior.ColorIndex = -4142 'убираем заливку если была
i = 3
For Each cell In Selection
If WorksheetFunction.CountIf(Selection, cell.Value) > 1 Then
For k = LBound(Dupes) To UBound(Dupes)
'если ячейка уже есть в массиве дубликатов - заливаем
If Dupes(k, 1) = cell Then cell.Interior.ColorIndex = Dupes(k, 2)
Next k
'если ячейка содержит дубликат, но еще не в массиве - добавляем ее в массив и заливаем
If cell.Interior.ColorIndex = -4142 Then
cell.Interior.ColorIndex = i
Dupes(i, 1) = cell.Value
Dupes(i, 2) = i
i = i + 1
End If
End If
Next cell
End Sub
Не могу найти такую команду, чтоб этот макрос игнорировал пустые ячейки (вместо этого он разынми цветами заливает пустые ячейки).
Пробова запихнуть SkipBlanks: = True, но не могу угадать куда именно. (ещё толком не знаком с VBA)
В ячейках, по которым ведётся поиск есть формула ЕСЛИ, которая при значении ИСТИНА выводит номера автомобилей (значения, которые нужно попарно подсветить дубликаты), а при значении ЛОЖЬ выводит "" (пустая ячейка).
skais675 написал: перед тем как залить цветом проверяйте на <>""
И ещё на <>Empty. Т.к. пустая ячейка <> ячейка, содержащая пустую строку, а исходный массив состоит из Variant'ов.
zhmerin, ещё обратите внимание, что cell у Вас - сам объект Range, а не значение в ячейке. Лучше проверять и присваивать cell.Value (значение ячейки + формат) или даже cell.Value2 (значение ячейки без формата), а не cell. Как-то так:
Код
For Each cell In Selection
If Not IsEmpty(cell.Value2) And cell.Value2 <> vbNullString Then 'Проверяем, что cell не пустая и не содержит пустую строку
If WorksheetFunction.CountIf(Selection, cell.Value) > 1 Then
For k = LBound(Dupes) To UBound(Dupes)
'если ячейка уже есть в массиве дубликатов - заливаем
If Dupes(k, 1) = cell.Value Then cell.Interior.ColorIndex = Dupes(k, 2)
Next k
'если ячейка содержит дубликат, но еще не в массиве - добавляем ее в массив и заливаем
If cell.Interior.ColorIndex = -4142 Then
cell.Interior.ColorIndex = i
Dupes(i, 1) = cell.Value
Dupes(i, 2) = i
i = i + 1
End If
End If
End If
Next cell
Sub test()
Dim arr(), rng, iarr
Dim dic As Object, i&
If Selection.Count = 1 Then Exit Sub
arr = Selection.Value
Set dic = CreateObject("Scripting.Dictionary")
Selection.Interior.ColorIndex = -4142
i = 3
For Each rng In arr
If Not IsEmpty(rng) Then dic.Item(CStr(rng)) = dic.Item(CStr(rng)) + 1
Next rng
For Each rng In dic.keys
If dic.Item(rng) > 1 Then dic.Item(rng) = dic.Item(rng) & "|" & i: i = i + 1 Else dic.Remove (rng)
Next rng
For Each rng In Selection
If dic.exists(CStr(rng.Value)) Then
iarr = Split(dic.Item(CStr(rng.Value)), "|")
If Val(iarr(0)) > 1 Then rng.Interior.ColorIndex = iarr(1)
End If
Next rng
End Sub