Макрос для поиска дубликатов строк

Question

Я ищу макрос для поиска повторяющихся строк в электронной таблице.До сих пор я придумал этот набор кода:

Application.ScreenUpdating = False

For Each cell In ActiveSheet.UsedRange.Columns("A").Cells
    For Each cell2 In ActiveSheet.UsedRange.Columns("A").Cells 'Loop through entire column A for each iteration in nested for loop
        If Cells(y, 1).Value = Cells(z, 1).Value Then 'Duplicate value found
            For icol = 1 To 19
                If Cells(y, icol).Value = Cells(z, icol).Value Then 'If cell value in current row matches, highlight red
                    Cells(z, icol).Interior.ColorIndex = 3
                End If
            Next icol
        End If

        z = z + 1
    Next cell2
    y = y + 1 'Next cell
    z = y + 1 'Next cell (y+1)
Next cell
Application.ScreenUpdating = True

Я подошел к этому с помощью вложенных циклов foor.Предполагается, что макрос ищет дублирующееся значение в столбце A. Если он найден, то цикл проходит по этой строке, чтобы проверить, совпадает ли вся строка.Каждая соответствующая ячейка в этом ряду затем выделяется красным.Похоже, что это хорошо работает в небольших масштабах, когда количество строк не слишком велико.Однако при применении этого макроса к электронной таблице с 7000+ строками Excel зависает и вылетает.Я подозреваю, что это связано с вложенными циклами.Есть ли более быстрый и практичный подход к этому?

Answer 1

Попробуйте условное форматирование вместо жесткого кодирования красной ячейки.

Option Explicit

Sub dupeRed()
    Dim lr As Long, lc As Long

    With Worksheets("sheet1")
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        With .Range(.Cells(2, "A"), .Cells(lr, lc))
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, _
              Formula1:="=AND(COUNTIF($A$1:$A1, $A2), A2=INDEX(A:A, MATCH($A2, $A:$A, 0)))"
            .FormatConditions(.FormatConditions.Count).Interior.Color = vbRed
        End With
    End With
End Sub