使用Excel VBA查找（不删除）multidimensional array中的重复值（行）

build立在我以前的一个问题上
我期待完成的是：

我正在寻找和重点使用基于多个标准的VBA代码重复的Upcharges：

  1. 产品的XID（A列）
  2. 上游标准1（CT列）
  3. 上游标准2（CU列）
  4. 上电types（CV列）和
  5. 上行电平（CW）

如果电子表格中有多个实例/行共享/匹配所有这些条件，则意味着Upcharge是重复的。 正如我在上面的链接上面看到的：

我试过了：

  1. 创build一个通用公式（见下文），插入到Helper列中，并一直向下复制到电子表格中，指出哪些Upcharges是重复的。 这种方法太耗费资源，耗时太长（所有公式计算需要8-10分钟，但过滤时不会滞后）。 然后我试了一下
  2. 将通用公式演化为一个条件格式公式，并通过VBA代码将其应用于Upcharge Name列（在过滤时需要相同的时间量和滞后时间）
  3. 我也看过可能使用scripting.dictionary ，但我不知道如何（或如果），将与multidimensional array。

现在我终于find了我认为会更快的方法，

我正在使用的更快的方法：将上述列转储到multidimensional array中，在数组中find重复的“行”，然后突出显示相应的电子表格行。

我试图更快的方法：这是我如何填充multidimensional 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

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

我的问题：

  1. 有没有一种方法可以将我的公式应用于我的上一篇文章中的第一次尝试（见下文），并将其应用到数组中？
  2. 或者，更好的是，有更快的方法，我可以在数组中find重复的“行”？
  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

你说识别重复; 我听到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对象的后期绑定转换为早期绑定，则必须将Microsoft脚本运行时添加到VBE的工具►引用。

条件格式和过滤

SUMPRODUCT与COUNTIFS

首先，您select的function对于如此大量的行以及多个条件是不合适的。 一个COUNTIFS函数可以执行SUMPRODUCT函数可以执行的许多相同的多个标准操作，但通常是计算负载和时间的25-35％。 此外，在COUNTIFS中可以使用完整的列引用，因为列引用在Worksheet.UsedRange属性的限制内部被截断。

你的标准公式可以用COUNTIFS写成， 

 =AND(COUNTIFS(A:A, A2, CT:CT, CT2, CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1, CT2<>"") '... or, =COUNTIFS(A:A, A2, CT:CT, CT2, CT:CT, "<>", CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1

将非空白列CT条件直接引入COUNTIFS函数实际上稍微改进了计算时间。

只有当你必须计算

原来的公式可以分解为两个主要条件。

  1. 列CT中的单元格是否为空白？
  2. 5列中的值是否与其他行的相同的5列匹配？

如果条件不成立，基本的IF函数会暂停处理。 如果将CT列中非空白单元格的testing移入换行IF，则只有在当前行CT列中有值时才会处理COUNTIFS（计算的大部分）。

改进的标准公式成为， 

 =IF(CT2<>"", COUNTIFS(A:A, A2, CT:CT, CT2, CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1)

这种修改的好处取决于列CT中空白单元格的数量。 如果15,000个单元中只有1％是空白的，则很less有改进会被注意到。 然而，如果CT列中的50％的单元格通常是空白的，那么将会有一个实质性的改进，因为你将计算周期敲了一半。

sorting数据以限制范围

到目前为止，最大的计算寄生虫是COUNTIFS通过五个单独的列查看15,000行数据。 如果数据是按照一个或多个标准列进行sorting的，则不必查看所有15,000行，以匹配所有五个标准列。

为了这个练习的目的，假定列A按升序排列。 如果你想testing这里讨论的假设，现在对数据进行sorting。

INDEX函数不仅仅是返回一个值; 它实际上返回一个有效的单元地址。 当用于最常见的查找容量时，您会看到返回的值，但实际上，与仅返回单元格值的类似VLOOKUP操作不同，INDEX正在返回实际单元格; 例如=A1 ，而不是A1包含的99 。 这个超级function可以用来创build可用于其他function的有效范围。 例如A2:A9也可以写成INDEX(A:A, 2):INDEX(A:A, 9) 。

此function不能在条件格式规则中直接使用。 但是，它可以在命名范围中使用，并且可以在条件格式规则中使用命名范围。

TL;博士 

 Sub lminyCFrule() Debug.Print Timer 'Application.ScreenUpdating = False '<~~ uncomment this once you are no longer debugging On Error Resume Next '<~~ needed for deleting objects without checking to see if they exist With Worksheets("Upcharge") '<~~ you know what worksheet you are supposed to be on If .AutoFilterMode Then .AutoFilterMode = False 'delete any existing defined name called 'localXID' or 'local200' With .Parent .Names("localXID").Delete .Names("local200").Delete End With 'create a new defined name called 'localXID' for CF rule method 1 .Names.Add Name:="localXID", RefersToR1C1:= _ "=INDEX('" & .Name & "'!C1:C104, MATCH('" & .Name & "'!RC1, '" & .Name & "'!C1, 0), 0):" & _ "INDEX('" & .Name & "'!C1:C104, MATCH('" & .Name & "'!RC1, '" & .Name & "'!C1 ), 0)" 'create a new defined name called 'local200' for CF rule method 2 .Names.Add Name:="local200", RefersToR1C1:= _ "=INDEX(Upcharge!C1:C104, MAX(2, ROW()-100), 0):INDEX(Upcharge!C1:C101, ROW()+100, 0)" With .Cells(1, 1).CurrentRegion 'sort on column A in ascending order .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _ Orientation:=xlTopToBottom, Header:=xlYes 'create a CF rule on column CS With .Resize(.Rows.Count - 1, 1).Offset(1, 96) With .FormatConditions .Delete ' method 1 and method 2. Only use ONE of these! ' method 1 - definitively start and end of XIDs in column A (slower, no mistakes) '.Add Type:=xlExpression, Formula1:= _ "=IF(CT2<>"""", COUNTIFS(INDEX(localXID, 0, 1), A2, INDEX(localXID, 0, 98), CT2," & _ "INDEX(localXID, 0, 99), CU2, INDEX(localXID, 0, 100), CV2," & _ "INDEX(localXID, 0, 101), CW2)-1)" ' method 2 - best guess at start and end of XIDs in column A (faster, guesswork at true scope) .Add Type:=xlExpression, Formula1:= _ "=IF(CT2<>"""", COUNTIFS(INDEX(local200, 0, 1), A2, INDEX(local200, 0, 98), CT2," & _ "INDEX(local200, 0, 99), CU2, INDEX(local200, 0, 100), CV2," & _ "INDEX(local200, 0, 101), CW2)-1)" End With .FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 3 End With 'Filter based on column CS is red .Columns(97).AutoFilter Field:=1, Criteria1:=vbRed, Operator:=xlFilterCellColor End With End With Application.ScreenUpdating = True Debug.Print Timer End Sub

虽然没有快速尖叫，但这个工作很方便。 “最佳猜测”比“明确的开始和结束”要快，但是你有可能没有完全覆盖A列中重复项的范围。当然，控制范围的偏移量（例如100个上下）调整。

为什么不移除Indirect()并用一些稳定的Row引用replaceCountif()函数。 由于Indirect()部分是一个易失性部分，而不是使用Indirect() ，所以可以直接使用一些稳定的行参考（如$A$2:$A$50000 ，这可能会在性能上发生一些显着的变化。

要么

为您的数据使用创build表。 在您的公式中使用表格引用将比Indirect()引用更快的工作。

编辑

你的实际公式 

 =AND(SUMPRODUCT(($A$2:$A$500=$A2)*($CU$2:$CU$500=$CU2)*($CV$2:$CV$500=$CV2)*($CW$2:$CW$500=$CW2)*($CX$2:$CX$500=$CX2))>1,$CU2 <> "")

为什么不把它转换为像下面这样稳定的参考的Counti(S) ？ 

 =AND(COUNTIFS($A$2:$A$500,$A2,$CU$2:$CU$500,$CU2,$CV$2:$CV$500,$CV2,$CW$2:$CW**$500,$CW2,$CX$2:$CX$500,$CX2)>1,$CU12<>"")

考虑一个SQL解决scheme，因为这是一个典型的查询聚合组，通过查询筛选出的计数大于1。要执行路由，需要在所有数组元素的循环中使用许多条件逻辑。

虽然我build议您只需将数据导入到Excel的同级MS Access等数据库中，但Excel可以使用ADO连接在自己的工作簿上运行SQL语句（而不是详细介绍Excel和Access使用相同的Jet / ACE引擎）。 一件好事是你似乎被设置为运行这样一个查询与表结构的命名列。

下面的示例在名为Data （ Data$ ）的工作表中引用您的字段，并将输出查询到名为Results （带有标题）的工作表中。 根据需要更改名称。 包括两个连接string（其中之一被注释掉）。 希望它能在你身上运行！ 

 Sub RunSQL() Dim conn As Object, rst As Object Dim i As Integer, fld As Object Dim strConnection As String, strSQL As String Set conn = CreateObject("ADODB.Connection") Set rst = CreateObject("ADODB.Recordset") ' Connection and SQL Strings ' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _ ' & "DBQ=C:\Path\To\Workbook.xlsm;" strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _ & "Data Source='C:\Path\To\Workbook.xlsm';" _ & "Extended Properties=""Excel 8.0;HDR=YES;"";" strSQL = " SELECT [Data$].[Product's XID], [Data$].[Upcharge Criteria 1]," _ & " [Data$].[Upcharge Criteria 2], [Data$].[Upcharge Type]," _ & " [Data$].[Upcharge Type], [Data$].[Upcharge Level]" _ & " FROM [Data$]" _ & " GROUP BY [Data$].[Product's XID], [Data$].[Upcharge Criteria 1]," _ & " [Data$].[Upcharge Criteria 2], [Data$].[Upcharge Type]," _ & " [Data$].[Upcharge Type], [Data$].[Upcharge Level]," _ & " [Data$].[Product's XID]" _ & " HAVING COUNT(*) > 1;" ' Open the db connection conn.Open strConnection rst.Open strSQL, conn ' Column headers i = 0 Worksheets("Results").Range("A1").Activate For Each fld In rst.Fields ActiveCell.Offset(0, i) = fld.Name i = i + 1 Next fld ' Data rows Worksheets("Results").Range("A2").CopyFromRecordset rst rst.Close conn.Close End Sub

这可能像一个魔术，但不知道它是否会工作。

你能不能创build另一个支持（临时）列，连接所有四个标准？

ZZ_Temp = concatenate（CS; CV; CZ;等）

这样，我想，你可以更快地显示/突出重复。

Interesting Posts

从multidimensional array中提取一维数组

在Excel Excel VBA中返回最小值的索引

从条件中删除VBA数组中的重复项

将行作为variables复制一个数组

运行时错误1004.对象未定义

将标题存储在string数组VBA中

在VBA中使用数组debugging

Powershell Excel从数组中添加行

将一个数组分配给vba中的另一个数组

返回主数组中匹配值的索引数组