Question

我一直在尝试编写一段vba代码，以便我可以在列中找到所有重复项，用红色突出显示它们并打开一个列出所有重复项的消息框;

我想要代码在多个工作表中为C列执行此操作。这基本上是替换条件格式，因为它减慢了工作簿大约8秒。

这是我到目前为止所做的，但它并没有真正起作用。

Sub FindDuplicates()

    Sheetcounter = 0
    Set MyData = Worksheets("Sheet1").Range("C1:C" & 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(" & MyData.Address & "," & Cell.Address & ")") > 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 & vbNewLine & 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:" & vbNewLine & MyDupList
        Else
        MsgBox "There were no duplicates found in " & MyData.Address
    End If
    Sheetcounter = Sheetcounter + 1
    If Sheetcounter = 1 Then
     Set MyData = Worksheets("Sheet2").Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    End If
    If Sheetcounter = 2 Then
     Set MyData = Worksheets("Sheet3").Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    End If

    Loop

End Sub

Answer 1

你可以简化你的子如下：

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" & 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:" & vbNewLine & Join(myUniqueList.Keys, vbNewLine)
        Else
            MsgBox "There were no duplicates found in " & myData.Address
        End If
    Next sheetCounter
End Sub

如何在列中查找重复项，循环遍历多个工作表

1 个答案: