arrays - 使用Excel VBA在多维数组中查找(而不是删除)重复值(行)

Question

^{以我的过去为基础 questions}
我希望实现的目标:

我希望使用基于多个条件的 VBA 代码查找并突出显示重复的费用:

1. 产品的 XID(A 列)
2. 附加费标准 1(色谱柱 CT)
3. 附加费标准 2(CU 列)
4. 充电类型(CV 列)和
5. 附加费水平(CW 列)

如果电子表格中有多个实例/行共享/匹配所有这些条件，则意味着附加费是重复的。正如我在上面链接的上一篇文章中所见:

我尝试过的:

1. 创建了一个通用公式(见下文)，该公式插入到辅助列中并一直复制到电子表格中，指出哪些附加费是重复的。这种方法资源消耗太大，耗时太长(所有公式计算需要 8-10 分钟，但过滤时不会滞后)。然后我尝试了
2. 将一般公式演变为条件格式公式，并通过 VBA 代码将其应用到“Upcharge Name”列。(过滤时花费相同的时间和滞后)
3. 我还研究了使用 scripting.dictionary 的可能性，但我不确定它如何(或是否)适用于多维数组。

现在我终于找到了我认为会快得多的方法，

我想要使用的更快的方法: 将上述列转储到多维数组中，找到数组中重复的“行”，然后突出显示相应的电子表格行。

我对更快方法的尝试: 这是我填充多维数组的方法

Sub populateArray()
    Dim arrXID() As Variant, arrUpchargeOne() As Variant, arrUpchargeTwo() As Variant, arrUpchargeType() As Variant, arrUpchargeLevel() As Variant
    Dim arrAllData() As Variant
    Dim i As Long, lrow As Long
    lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    arrXID = Range("A2:A" & lrow) 'amend column number
    arrUpchargeOne = Range("CT2:CT" & lrow)
    arrUpchargeTwo = Range("CU2:CU" & lrow)
    arrUpchargeType = Range("CV2:CV" & lrow)
    arrUpchargeLevel = Range("CW2:CW" & lrow)

    ReDim arrAllData(1 To UBound(arrXID, 1), 4) As Variant
        For i = 1 To UBound(arrXID, 1)
            arrAllData(i, 0) = arrXID(i, 1)
            arrAllData(i, 1) = arrUpchargeOne(i, 1)
            arrAllData(i, 2) = arrUpchargeTwo(i, 1)
            arrAllData(i, 3) = arrUpchargeType(i, 1)
            arrAllData(i, 4) = arrUpchargeLevel(i, 1)
        Next i
End Sub

我可以将列放入数组中，但我从那里卡住了。我不知道如何去检查数组中重复的“行”。

我的问题:

1. 有没有办法可以应用我在上一篇文章中第一次尝试的公式(见下文)并将其应用到数组中？:
2. 或者，更好的是，是否有一种更快的方法可以找到数组内重复的“行”？
3. 那么我该如何突出显示电子表格行中与数组中标记为重复的“行”相对应的 Upcharge Name (CS) 单元格呢？

_{我之前帖子中的公式供引用:}

=AND(SUMPRODUCT(($A$2:$A$" & lastRow & "=$A2)*($CT$2:$CT$" & lastRow & "=$CT2)*($CU$2:$CU$" & lastRow & "=$CU2)*($CV$2:$CV$" & lastRow & "=$CV2)*($CW$2:$CW$" & lastRow & "=$CW2))>1,$CT2 <> """")"
Returns TRUE if Upcharge is a duplicate 

Answer 1

你说识别重复项；我听说Scripting.Dictionary对象。

Public Sub lminyDupes()
    Dim d As Long, str As String, vAs As Variant, vCTCWs As Variant
    Dim dDUPEs As Object                      '<~~ Late Binding
    'Dim dDUPEs As New Scripting.Dictionary   '<~~ Early Binding

    Debug.Print Timer
    Application.ScreenUpdating = False '<~~ uncomment this once you are no longer debugging

    'Remove the next line with Early Binding¹
    Set dDUPEs = CreateObject("Scripting.Dictionary")
    dDUPEs.comparemode = vbTextCompare

    With Worksheets("Upcharge") '<~~ you know what worksheet you are supposed to be on
        With .Cells(1, 1).CurrentRegion
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                .Columns(97).Interior.Pattern = xlNone  '<~~ reset column CS

                'the following is intended to mimic a CF rule using this formula
                '=AND(COUNTIFS(A:A, A2, CT:CT, CT2, CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1, SIGN(LEN(CT2)))

                vAs = .Columns(1).Value2
                vCTCWs = Union(.Columns(98), .Columns(99), .Columns(100), .Columns(101)).Value2

                For d = LBound(vAs, 1) To UBound(vAs, 1)
                    If CBool(Len(vCTCWs(d, 1))) Then
                        'make a key of the criteria values
                        str = Join(Array(vAs(d, 1), vCTCWs(d, 1), vCTCWs(d, 2), vCTCWs(d, 3), vCTCWs(d, 4)), ChrW(8203))
                        If dDUPEs.exists(str) Then
                            'the comboned key exists in the dictionary; append the current row
                            dDUPEs.Item(str) = dDUPEs.Item(str) & Chr(44) & "CS" & d
                        Else
                            'the combined key does not exist in the dictionary; store the current row
                            dDUPEs.Add Key:=str, Item:="CS" & d
                        End If
                    End If
                Next d

                'reuse a variant var to provide row highlighting
                Erase vAs
                For Each vAs In dDUPEs.keys
                    'if there is more than a single cell address, highlight all
                    If CBool(InStr(1, dDUPEs.Item(vAs), Chr(44))) Then _
                        .Range(dDUPEs.Item(vAs)).Interior.Color = vbRed
                Next vAs
            End With
        End With

    End With

    dDUPEs.RemoveAll: Set dDUPEs = Nothing
    Erase vCTCWs

    Application.ScreenUpdating = True
    Debug.Print Timer

End Sub

这似乎比公式方法更快。

<小时/>

¹ _{如果您计划将 Scripting.Dictionary 对象的后期绑定(bind)转换为早期绑定(bind)，则必须添加 Microsoft Scripting Runtime VBE 工具►引用。}