Vba 匹配多个列时查找重复项

@alon adler昨天帮助我创建了一些VBA代码，以从Excel工作表中删除重复的行，因此我们正在查询的单元格具有某种颜色，并且在同一列中有另一个具有相同值的单元格

我现在需要调整代码，以匹配行中的多个列，而不仅仅是一个列。 他的密码如下：

Sub sbFindDuplicatesInColumn_With_Color_Condition()

Dim toDel(), i As Long
Dim RNG As Range, Cell As Long

'Declare and set the worksheet where your data is stored
Dim sheet As Worksheet
Set sheet = Worksheets("Sheet1")

'Finding the last row in the Column 1
lastRow = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row

'Set the range to the last row of data in the column
Set RNG = Range("a1:a" & lastRow) 'set your range here

'Iterate over the column, finding duplicates and store their address in an array
For Cell = 1 To RNG.Cells.Count
    If Application.CountIf(RNG, RNG(Cell)) > 1 Then
        ReDim Preserve toDel(i)
        toDel(i) = RNG(Cell).Address
        i = i + 1
    End If
Next
'Iterate over the array and remove duplicates with specific color index (in this example - remove the yellow ones)
For i = UBound(toDel) To LBound(toDel) Step -1
    If Range(toDel(i)).Cells.Interior.ColorIndex = 6 Then
        Range(toDel(i)).Cells.Value = ""
    End If
Next i

End Sub

我对VBA真的不是很了解，我想知道一种有效的方法（电子表格有大约45000行要检查），来调整代码以检查一系列列是否与另一行匹配

例如，我们希望确保将一行视为重复行，列a到O中的所有单元格必须与另一行上相应列中的值匹配

如果该行不是白色的，则需要删除该行。我确定删除命令将是：

Rows(RowToDel).EntireRow.Delete

我相信我会改变：

If Range(toDel(i)).Cells.Interior.ColorIndex = 6 Then

致：

If Range（toDel（i））.Cells.Interior.ColorIndex 0然后

---

如果有人能帮我匹配多个栏目，我想我会很乐意去的。

试试下面的方法。对于支持图像中显示的数据，第2行将被删除，因为它是重复的，并且其内部与-4142不同，即具有填充

代码放在标准模块中

您可以取消对删除代码的注释以执行删除

unionRng.EntireRow.Delete

并注释掉

Debug.Print unionRng.EntireRow.Address 

当前显示将删除的内容

是的，它有点混乱，可能需要一些重新分解，例如，您可能会使用Join将Evaluate（CONCATENATE…）字符串缩减为更短的字符串

代码：

选项显式
公共子SBFindDopplicatesColumn_（带颜色条件）（）
变暗RNG As范围
将wb设置为工作簿
与当前行一样长
将目标工作表变暗为工作表
最后一排一样长
设置wb=ThisWorkbook
Set targetSheet=wb.工作表（“表1”）
有目标表
lastRow=.Cells（.Rows.Count，1）.End（xlUp）.Row'查找列A中的最后一行，并使用它确定要处理的范围内的行数
Set RNG=.Range（“A1:O”&lastRow）”在此处设置范围
Dim toDel（）
toDel=RNG.Value2
重读保存toDel（1到UBound（toDel，1），1到UBound（toDel，2）+2）
Dim concatValuesDict作为脚本。Dictionary作为对象
Set concatValuesDict=New Scripting.Dictionary'=CreateObject（“Scripting.Dictionary”）
对于currentRow=LBound（toDel，1）到UBound（toDel，1）
Dim joinedString作为字符串
joinedString=Evaluate（“连接”（“&toDel（currentRow，1）&“，”&toDel（currentRow，2）&toDel（currentRow，3）&“，”_
&托德尔（当前行，4）和托德尔（当前行，5）和托德尔（当前行，6）和托德尔（当前行，6）和_
托德尔（当前行，7）和托德尔（当前行，8）和托德尔（当前行，9）和托德尔（当前行，10）和托德尔（当前行，10）和_
托德尔（当前行，11）和“，”和托德尔（当前行，12）和“，”和托德尔（当前行，13）和“，”和托德尔（当前行，14）和“，”和”_
toDel（currentRow，15）和““””）“为每一行创建一个唯一的键，通过连接范围中的每一列来确定重复项
toDel（当前行，UBound（toDel，2）-1）=连接字符串
如果concatValuesDict.不存在（joinedString），则
concatValuesDict.Add joinedString，False'将这些“键”添加到字典中，如果“键”尚未出现，则关联的字典值=False
其他的
concatValuesDict（joinedString）=True“键在前面看到，所以重复，所以将值设置为True
如果结束
下一行
调光范围
对于currentRow=LBound（toDel，1）到UBound（toDel，1）
toDel（当前行，UBound（toDel，2））=concatValuesDict（toDel（当前行，UBound（toDel，2）-1））
如果toDel（currentRow，UBound（toDel，2））和targetSheet.Rows（currentRow）.Interior.ColorIndex-4142，则“应用一些填充，并且此行的字典值为真（即重复）
如果不是的话，RNG什么都不是
Set unionRng=Union（unionRng，targetSheet.Rows（currentRow）.Cells（1，1））'将键添加到一个范围中，以便以后使用Union删除
其他的
Set unionRng=targetSheet.Rows（currentRow）.Cells（1,1）
如果结束
如果结束
下一行
如果不是的话，RNG什么都不是
Debug.Print unionRng.EntireRow.Address
'unionRng.EntireRow.Delete
如果结束
以
端接头

数据图像：

运行示例：

---

我最初的想法是在阵列中捕获你的射程。然后开始将每一行添加到字典中。在将其添加到词典之前，请检查词典是否已包含该项。如果有，你知道你有一个副本。如果没有，请将其添加到词典中。如果我有时间，我会在答案中添加代码。这只是给你一个想法，你可以采取的方法感谢这一点。听起来它能满足我的要求。虽然“未定义用户定义的类型”，但我得到了一个编译错误。似乎是针对“Dim concatValuesDict As Scripting.Dictionary”的，是否可以对其中一些行进行注释，以便我能够理解代码在每个阶段所做的工作？感谢您已通过根据此问题启用引用解决了此问题：我现在正在运行它，但它不起任何作用，甚至没有给我调试消息。您好，很抱歉，我应该提到此引用。我会看一看，看看可能是什么问题，但它表明unionRng什么都不是，即没有找到匹配的行，因此需要检查为什么不满足向unionRangdI添加行的if条件。我已经为您添加了一些注释

Debug.Print unionRng.EntireRow.Address 

Option Explicit

Public Sub sbFindDuplicatesInColumn_With_Color_Condition()

    Dim RNG As Range
    Dim wb As Workbook
    Dim currentRow As Long

    Dim targetSheet As Worksheet
    Dim lastRow As Long

    Set wb = ThisWorkbook
    Set targetSheet = wb.Worksheets("Sheet1")

    With targetSheet

        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'find the last row in column A and use this to determine the number of rows in range to work with

        Set RNG = .Range("A1:O" & lastRow)       'set your range here

        Dim toDel()
        toDel = RNG.Value2
        ReDim Preserve toDel(1 To UBound(toDel, 1), 1 To UBound(toDel, 2) + 2)

        Dim concatValuesDict As Scripting.Dictionary 'As Object
        Set concatValuesDict = New Scripting.Dictionary ' = CreateObject("Scripting.Dictionary")

        For currentRow = LBound(toDel, 1) To UBound(toDel, 1)

            Dim joinedString As String

            joinedString = Evaluate("CONCATENATE(""" & toDel(currentRow, 1) & """,""" & toDel(currentRow, 2) & toDel(currentRow, 3) & """,""" _
            & toDel(currentRow, 4) & """,""" & toDel(currentRow, 5) & """,""" & toDel(currentRow, 6) & """,""" & _
            toDel(currentRow, 7) & """,""" & toDel(currentRow, 8) & toDel(currentRow, 9) & """,""" & toDel(currentRow, 10) & """,""" & _
            toDel(currentRow, 11) & """,""" & toDel(currentRow, 12) & """,""" & toDel(currentRow, 13) & """,""" & toDel(currentRow, 14) & """,""" & _
           toDel(currentRow, 15) & """)") 'create a unique key for each row to determine duplicates by concatenating each column in the range

           toDel(currentRow, UBound(toDel, 2) - 1) = joinedString

           If Not concatValuesDict.Exists(joinedString) Then
               concatValuesDict.Add joinedString, False 'add these "keys" to a dictionary, and if "key" not already present then associated dictionary value =False
           Else
              concatValuesDict(joinedString) = True 'key seen before so duplicate so set value to True
           End If

        Next currentRow

        Dim unionRng As Range

        For currentRow = LBound(toDel, 1) To UBound(toDel, 1)

           toDel(currentRow, UBound(toDel, 2)) = concatValuesDict(toDel(currentRow, UBound(toDel, 2) - 1))

         If toDel(currentRow, UBound(toDel, 2)) And targetSheet.Rows(currentRow).Interior.ColorIndex <> -4142 Then  'Some fill is applied and the dictionary value for this row is True (i.e. is a duplicate)

             If Not unionRng Is Nothing Then
                Set unionRng = Union(unionRng, targetSheet.Rows(currentRow).Cells(1, 1))   'add the key to a range for later deletion using union 
             Else
                Set unionRng = targetSheet.Rows(currentRow).Cells(1, 1)
             End If
         End If

        Next currentRow

        If Not unionRng Is Nothing Then

            Debug.Print unionRng.EntireRow.Address
            ' unionRng.EntireRow.Delete

        End If

    End With

End Sub