寻找在多维数组使用Excel VBA（不删除）重复值（行） [英] Finding (NOT deleting) duplicate values(rows) in multi-dimensional array using Excel VBA

问题描述

^{建筑了我过去的一<一href=\"http://stackoverflow.com/questions/35183844/how-to-apply-conditional-formatting-formula-to-large-range-faster\">questions}
What我希望实现的：

我希望找到并突出使用VBA code根据多个条件重复Upcharges：

1. 产品的XID（列A）


2. 加收费用标准1（列CT）


3. 加收费用标准2（列CU）


4. 加收费用类型（列CV）和


5. 加收费用水平（列CW）

如果有多个实例/行A S preadsheet该共享/符合所有这些标准，那么这意味着加收费用是重复的。正如我在previous后看到上面链接：

我已经试过：

1. 创建一个通式（见下文）插入到一个辅助列，并复制一路下跌在S preadsheet其中指出了Upcharges是重复的。这种方法过于沉重的资源和时间太长（8-10分钟，所有的公式来计算，但过滤时不滞后）。然后我试图


2. 孕育通式为一个条件格式公式并将其应用到通过VBA code中的加收费用名称列。（所花的时间相同数量和LAG过滤时）


3. 我也看着可能使用的Scripting.Dictionary ，但我不知道如何（或者），将用多维数组工作。

现在我终于发现，我认为将是方法要快得多，

更快的方法，我在寻找使用方法：
倾倒上述列插入多维数组，找到数组中重复的行，则凸显了相应的S preadsheet行。

我试图以更快的方法：
以下是我填充多维数组

 子populateArray（）
    昏暗arrXID（）作为变，arrUpchargeOne（）作为变，arrUpchargeTwo（）作为变，arrUpchargeType（）作为变，arrUpchargeLevel（）为Variant
    昏暗arrAllData（）为Variant
    昏暗我一样长，lrow只要
    lrow = ActiveSheet.Cells（Rows.Count，1）.END（xlUp）.Row    arrXID =范围（A2：A＆放大器; lrow）修改列数
    arrUpchargeOne =范围（CT2：CT＆放大器; lrow）
    arrUpchargeTwo =范围（CU2：CU与＆amp; lrow）
    arrUpchargeType =范围（CV2：CV＆放大器; lrow）
    arrUpchargeLevel =范围（CW2：CW＆放大器; lrow）    使用ReDim arrAllData（1向UBound函数（arrXID，1），4）作为变
        对于i = 1到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）
        接下来，我
结束小组
 

我可以列到数组，但我会被卡住从那里。我不知道如何去数组中检查重复的行。

我的问题：

1. 有没有我可以从我第一次尝试使用我的公式（见下文）在我的previous后，并将其应用在数组中的一种方式：


2. ，或者甚至更好，有没有更快的方法我能找到重复的行数组里面呢？


3. 然后我怎么能去突出加收费用名称在与被标记为重复阵列中的行对应在S preadsheet行（CS）的细胞？

<子>公式从我的previous后，以供参考：

  = 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 $与＆amp; LASTROW＆放大器;= $ CW2））大于1，$ CT2＆所述;＆gt;中，）
如果加收费用是重复的，则返回TRUE
 

解决方案

您说的识别重复;我听到 的Scripting.Dictionary对象。

 公用Sub lminyDupes（）
    昏暗Ð长，str作为字符串，输精管为Variant，vCTCWs为Variant
    昏暗dDUPEs作为对象'＆LT; ~~后期绑定
    昏暗dDUPEs作为新的Scripting.Dictionary'＆LT; ~~早期绑定    Debug.Print定时器
    Application.ScreenUpdating =假'＆LT; ~~取消注释你这一次不再调试    删除与早期Binding¹下一行
    设置dDUPEs =的CreateObject（的Scripting.Dictionary）
    dDUPEs.comparemode = vbTextCompare    随着工作表（加收费用），'＆LT; ~~你知道你应该有什么工作要上
        与.Cells（1，1）.CurrentRegion
            与.Resize（.Rows.Count  -  1，.Columns.Count）.Offset（1,0）
                .Columns（97）.Interior.Pattern = xlNone'＆LT; ~~重置列CS                '下述内容是用这个公式来模仿CF规则
                '= 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 =联盟（.Columns（98），.Columns（99），.Columns（100），.Columns（101））。值2                对于D = LBOUND（VAS，1）UBound函数（VAS，1）
                    如果CBool​​函数（莱恩（vCTCWs（D，1）））然后
                        使标准值的关键
                        海峡=加入（阵列（VAS（D，1），vCTCWs（D，1），vCTCWs（D，2），vCTCWs（D，3），vCTCWs（D，4）），CHRW（8203））
                        如果dDUPEs.exists（STR）。然后
                            在comboned关键存在于字典;追加当前行
                            dDUPEs.Item（STR）= dDUPEs.Item（STR）及字符（44）及CS＆放大器; ð
                        其他
                            组合键并不在字典里存在;存储当前行
                            dDUPEs.Add键：= str中，货号：=CS＆放大器; ð
                        万一
                    万一
                接下来ð                重复使用一个变量VAR提供行高亮
                擦除VAS
                对于每一个在VAS dDUPEs.keys
                    如果有比单个单元格地址多了，都凸显
                    如果CBool​​函数（INSTR（1，dDUPEs.Item（VAS），CHR（44）））然后_
                        .Range（dDUPEs.Item（VAS））。Interior.Color = vbRed
                接下来VAS
            结束与
        结束与    结束与    dDUPEs.RemoveAll：设置dDUPEs =什么
    擦除vCTCWs    Application.ScreenUpdating = TRUE
    Debug.Print定时器结束小组
 

这似乎比公式的方法更快。

---

¹<子>如果您打算转换的对象的Scripting.Dictionary的后期绑定早期绑定，您必须添加的 Microsoft脚本运行时 的VBE的工具►引用。

^{Building off of one of my past questions}
What I'm looking to accomplish:

I'm looking to find and highlight duplicate Upcharges using VBA code based on multiple criteria:

1. Product's XID (Column A)
2. Upcharge Criteria 1 (Column CT)
3. Upcharge Criteria 2 (Column CU)
4. Upcharge Type (Column CV) and
5. Upcharge Level (Column CW)

If there is more than one instance/row in a spreadsheet that share/match ALL of these criteria then that means the Upcharge is a duplicate. As seen in my previous post linked above:

What I've tried:

1. Created a general formula (see below) that is inserted into a Helper column and copied all the way down the spreadsheet which points out which Upcharges are duplicate. This method was too resource heavy and took too long (8-10 minutes for all the formulas to calculate, but doesn't lag when filtering). Then I tried
2. Evolved the general formula into a Conditional Formatting Formula and applied it to the Upcharge Name column via VBA code.(Takes same amount of time AND lags when filtering)
3. I've also looked into possibly using a scripting.dictionary, but I'm not sure how (or if) that would work with a multi-dimensional array.

Now I've finally found the method I think will be much faster,

The faster method I'm looking to use: Dumping the aforementioned columns into a multi-dimensional array, finding the duplicate "rows" in the array, then highlighting the corresponding spreadsheet rows.

My attempt at the faster method: Here's how I populate the multi-dimensional array

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

I can get the columns into the array, but I get stuck from there. I'm not sure how to go about checking for the duplicate "rows" in the array.

My questions:

1. Is there a way I can apply my formula (see below) from my first attempt in my previous post and apply it inside the array?:
2. Or, even better, is there a faster way I can find the duplicate "rows" inside the array?
3. Then how could I go about highlighting the Upcharge Name (CS) cell in the spreadsheet rows that correspond with the "rows" in the array that were flagged as duplicates?

_{Formula from my previous post for reference:}

=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 

解决方案

You say identify duplicates; I hear Scripting.Dictionary object.

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

This seems faster than the formula approach.

---

¹ _{If you plan to convert the late binding of the Scripting.Dictionary object to early binding, you must add Microsoft Scripting Runtime to the VBE's Tools ► References.}

这篇关于寻找在多维数组使用Excel VBA（不删除）重复值（行）的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！