Блог

Я пытался написать фрагмент кода vba, чтобы я мог найти все дубликаты в столбце, выделить их красным и открыть окно сообщения со списком всех дублированных;

и я хочу, чтобы код делал это для столбца C на нескольких листах. По сути, это замена условного форматирования, поскольку оно замедляло работу книги примерно на 8 секунд.

Это то, что у меня есть до сих пор, но на самом деле это не работает.

 Sub FindDuplicates()

    Sheetcounter = 0
    Set MyData = Worksheets("Sheet1").Range("C1:C" amp; Cells(Rows.Count, "C").End(xlUp).Row)

    Do Until Sheetcounter = 3
    Set MyUniqueList = CreateObject("Scripting.Dictionary")
    MyUniqueList.RemoveAll

    Range(Cells(1, 1), Cells(5000, 1)).Interior.Color = xlNone

    Application.ScreenUpdating = False

    MyDupList = "": MyCounter = 0

    For Each Cell In MyData
            If Evaluate("COUNTIF(" amp; MyData.Address amp; "," amp; Cell.Address amp; ")") > 1 Then
                If Cell.Value <> "" Then
                    Cell.Interior.Color = RGB(255, 80, 80)
                        If MyUniqueList.exists(CStr(Cell)) = False Then
                            MyCounter = MyCounter   1
                            MyUniqueList.Add CStr(Cell), MyCounter
                                If MyDupList = "" Then
                                    MyDupList = Cell
                                Else
                                    MyDupList = MyDupList amp; vbNewLine amp; Cell
                                End If
                        End If
                End If
            Else
                    Cell.Interior.ColorIndex = xlNone
            End If
    Next Cell

    Application.ScreenUpdating = True

    If MyDupList <> "" Then
        MsgBox "The following entries have been used more than once:" amp; vbNewLine amp; MyDupList
        Else
        MsgBox "There were no duplicates found in " amp; MyData.Address
    End If
    Sheetcounter = Sheetcounter   1
    If Sheetcounter = 1 Then
     Set MyData = Worksheets("Sheet2").Range("C1:C" amp; Cells(Rows.Count, "C").End(xlUp).Row)
    End If
    If Sheetcounter = 2 Then
     Set MyData = Worksheets("Sheet3").Range("C1:C" amp; Cells(Rows.Count, "C").End(xlUp).Row)
    End If

    Loop

End Sub
  

вы можете упростить свой подраздел следующим образом:

 Option Explicit

Sub FindDuplicates()
    Dim sheetCounter As Long
    Dim myData As Range, cell As Range
    Dim myUniqueList As Scripting.Dictionary

    Set myUniqueList = CreateObject("Scripting.Dictionary")
    For sheetCounter = 1 To 3
        myUniqueList.RemoveAll
        With Worksheets("Sheet00" amp; sheetCounter)
            Set myData = .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
        End With
        myData.Interior.Color = xlNone

        For Each cell In myData.SpecialCells(xlCellTypeConstants)
            If WorksheetFunction.CountIf(myData, cell) > 1 Then
                cell.Interior.Color = RGB(255, 80, 80)
                If Not myUniqueList.Exists(CStr(cell)) Then myUniqueList.Add CStr(cell), myUniqueList.Count   1
            End If
        Next cell

        If myUniqueList.Count > 0 Then
            MsgBox "The following entries have been used more than once:" amp; vbNewLine amp; Join(myUniqueList.Keys, vbNewLine)
        Else
            MsgBox "There were no duplicates found in " amp; myData.Address
        End If
    Next sheetCounter
End Sub