使用 Excel VBA 在多维数组中查找（不删除）重复值（行）
Finding (NOT deleting) duplicate values(rows) in multi-dimensional array using Excel VBA
以我的过去为基础 questions
我想要完成的事情：
我希望根据多个条件使用 VBA 代码查找并突出显示重复的 Upcharges：
- 产品的 XID（A 列）
- 附加费标准 1（CT 列）
- 附加费标准 2（CU 列）
- 追加费用类型（CV 列）和
- 附加费水平（CW 列）
如果电子表格中有多个 instance/row share/match 所有这些标准，那么这意味着附加费是重复的。正如我在上面链接的 post 中看到的那样：
我试过的：
- 创建了一个通用公式（见下文），该公式被插入到辅助列中，并一直复制到电子表格中，指出哪些附加费是重复的。这种方法太耗资源，耗时太长（8-10 分钟计算所有公式，但过滤时不滞后）。然后我试了
- 将通用公式演变成条件格式公式，并通过 VBA 代码将其应用于 Upcharge Name 列。（过滤时花费相同的时间和滞后）
- 我也研究过使用
scripting.dictionary 的可能性，但我不确定它如何（或是否）适用于多维数组。
现在我终于找到了我认为会更快的方法，
我希望使用的更快的方法：
将上述列转储到一个多维数组中，在数组中找到重复的 "rows"，然后突出显示相应的电子表格行。
我尝试的更快的方法：
这是我如何填充多维数组
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
我可以将列放入数组中，但我从那里卡住了。我不确定如何检查数组中的重复项 "rows"。
我的问题：
- 有没有一种方法可以应用我之前 post 中第一次尝试的公式（见下文）并将其应用到数组中？:
- 或者，更好的是，有没有更快的方法可以在数组中找到重复项 "rows"？
- 那么我怎样才能在电子表格行中突出显示与数组中被标记为重复的 "rows" 相对应的 Upcharge Name (CS) 单元格？
我之前post的公式供参考：
=AND(SUMPRODUCT(($A:$A$" & lastRow & "=$A2)*($CT:$CT$" & lastRow & "=$CT2)*($CU:$CU$" & lastRow & "=$CU2)*($CV:$CV$" & lastRow & "=$CV2)*($CW:$CW$" & lastRow & "=$CW2))>1,$CT2 <> """")"
Returns TRUE if Upcharge is a duplicate
考虑一个 SQL 解决方案，因为这是一个典型的 aggregate group by query 解决方案，您可以在其中过滤大于 1 的计数。要执行您的路线，需要在遍历数组所有元素的循环中使用许多条件逻辑。
虽然我建议您只需将数据导入数据库，例如 Excel 的同级 MS Access，Excel 可以 运行 SQL 在其自己的工作簿上使用语句一个 ADO connection（不详细说明，但 Excel 和 Access 使用相同的 Jet/ACE 引擎）。一件好事是，您似乎设置了 运行 这样的查询，其中的命名列结构类似于 table。
以下示例在名为 Data (Data$) 的工作表中引用您的字段，并将查询输出查询到名为 Results[=22= 的工作表]（headers）。根据需要更改名称。包含两个连接字符串（其中一个被注释掉）。希望它 运行 就在你身边！
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
为什么不删除 Indirect() 并用一些稳定的 Row 引用替换 Countif() 函数。由于 Indirect() 部分是易变的，而不是使用 Indirect()，您可以直接使用一些稳定的行引用，如 $A:$A000，这可能会显示一些显着的性能变化。
或
为您的数据使用创建 Table。在您的公式中使用 Table 参考，这比 Indirect() 参考更快。
编辑
你的实际公式
=AND(SUMPRODUCT(($A:$A0=$A2)*($CU:$CU0=$CU2)*($CV:$CV0=$CV2)*($CW:$CW0=$CW2)*($CX:$CX0=$CX2))>1,$CU2 <> "")
你为什么不把它转换成 Counti(S) 像下面这样的稳定引用？
=AND(COUNTIFS($A:$A0,$A2,$CU:$CU0,$CU2,$CV:$CV0,$CV2,$CW:$CW**0,$CW2,$CX:$CX0,$CX2)>1,$CU12<>"")
你说识别重复；我听到 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 Scripting Runtime 添加到VBE 的工具 ► 参考资料。
这可能像变魔术一样有效，但不确定是否有效。
您能否创建另一个支持性（临时）列，将所有四个条件串联起来？
ZZ_Temp = 连接（CS；CV；CZ；等）
我想这样，您可以 show/highlight 复制得更快。
条件格式和过滤
首先，您选择的函数不适合如此大量的行和多个条件。 A COUNTIFS function can perform many of the same multiple criteria operations that a SUMPRODUCT function can but in typically 25-35% of the calculation load and time. Additionally, full column references can be used without detriment in COUNTIFS as the column references are internally truncated at the limits of the Worksheet.UsedRange property.
您的标准公式可以用 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 函数实际上稍微缩短了计算时间。
Only Calculate When You Have To
原来的公式可以分解为两个主要条件。
- CT 列中的单元格是否为非空白？
- 五列中的值是否与任何其他行中的相同五列匹配？
如果条件不成立，基本的 IF function 会停止处理。如果将 CT 列中非空白单元格的测试移至环绕 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% 是空白的，则几乎看不到任何改进。但是，如果 CT 列中 50% 的单元格通常为空白，将会有实质性的改进，因为您实际上是在将计算周期减半。
Sorting the Data to Limit the Ranges
到目前为止，最大的计算寄生虫是 COUNTIFS 在五个单独的列中查看 15,000 行数据。如果数据是根据一个或多个条件列排序的，则无需查看所有 15,000 行以查找与所有五个条件列的匹配项。
For the purpose of this exercise, it will be assumed that column A is sorted in an ascending manner. If you want to test the hypothesis discussed here, sort the data now.
INDEX function does more than return a value; it actually returns a valid cell address. When used in its most common lookup capacity, you see the value returned but in reality, unlike a similar VLOOKUP操作只return单元格的值，INDEX是returning实际单元格；例如=A1，而不是 A1 包含的 99。这种超级功能可用于创建可在其他功能中使用的有效范围。例如A2:A9也可以写成INDEX(A:A, 2):INDEX(A:A, 9).
This functionality cannot be used directly within a Conditional Formatting rule. However, it can be used in a Named Range and a Named Range can be used in a Conditional Formatting rule.
tl;dr
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
虽然不会很快尖叫，但它可以轻松完成工作。 'best guess' 比 'definitive start and finish' 快，但你 运行 有不完全覆盖 A 列中重复项范围的风险。当然，偏移量（例如 100 上下）控制范围可调整
以我的过去为基础 questions
我想要完成的事情：
我希望根据多个条件使用 VBA 代码查找并突出显示重复的 Upcharges：
- 产品的 XID（A 列）
- 附加费标准 1（CT 列）
- 附加费标准 2（CU 列）
- 追加费用类型（CV 列）和
- 附加费水平（CW 列）
如果电子表格中有多个 instance/row share/match 所有这些标准，那么这意味着附加费是重复的。正如我在上面链接的 post 中看到的那样：
我试过的：
- 创建了一个通用公式（见下文），该公式被插入到辅助列中，并一直复制到电子表格中，指出哪些附加费是重复的。这种方法太耗资源，耗时太长（8-10 分钟计算所有公式，但过滤时不滞后）。然后我试了
- 将通用公式演变成条件格式公式，并通过 VBA 代码将其应用于 Upcharge Name 列。（过滤时花费相同的时间和滞后）
- 我也研究过使用
scripting.dictionary的可能性，但我不确定它如何（或是否）适用于多维数组。
现在我终于找到了我认为会更快的方法，
我希望使用的更快的方法： 将上述列转储到一个多维数组中，在数组中找到重复的 "rows"，然后突出显示相应的电子表格行。
我尝试的更快的方法： 这是我如何填充多维数组
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
我可以将列放入数组中，但我从那里卡住了。我不确定如何检查数组中的重复项 "rows"。
我的问题：
- 有没有一种方法可以应用我之前 post 中第一次尝试的公式（见下文）并将其应用到数组中？:
- 或者，更好的是，有没有更快的方法可以在数组中找到重复项 "rows"？
- 那么我怎样才能在电子表格行中突出显示与数组中被标记为重复的 "rows" 相对应的 Upcharge Name (CS) 单元格？
我之前post的公式供参考：
=AND(SUMPRODUCT(($A:$A$" & lastRow & "=$A2)*($CT:$CT$" & lastRow & "=$CT2)*($CU:$CU$" & lastRow & "=$CU2)*($CV:$CV$" & lastRow & "=$CV2)*($CW:$CW$" & lastRow & "=$CW2))>1,$CT2 <> """")"
Returns TRUE if Upcharge is a duplicate
考虑一个 SQL 解决方案，因为这是一个典型的 aggregate group by query 解决方案，您可以在其中过滤大于 1 的计数。要执行您的路线，需要在遍历数组所有元素的循环中使用许多条件逻辑。
虽然我建议您只需将数据导入数据库，例如 Excel 的同级 MS Access，Excel 可以 运行 SQL 在其自己的工作簿上使用语句一个 ADO connection（不详细说明，但 Excel 和 Access 使用相同的 Jet/ACE 引擎）。一件好事是，您似乎设置了 运行 这样的查询，其中的命名列结构类似于 table。
以下示例在名为 Data (Data$) 的工作表中引用您的字段，并将查询输出查询到名为 Results[=22= 的工作表]（headers）。根据需要更改名称。包含两个连接字符串（其中一个被注释掉）。希望它 运行 就在你身边！
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
为什么不删除 Indirect() 并用一些稳定的 Row 引用替换 Countif() 函数。由于 Indirect() 部分是易变的，而不是使用 Indirect()，您可以直接使用一些稳定的行引用，如 $A:$A000，这可能会显示一些显着的性能变化。
或
为您的数据使用创建 Table。在您的公式中使用 Table 参考，这比 Indirect() 参考更快。
编辑
你的实际公式
=AND(SUMPRODUCT(($A:$A0=$A2)*($CU:$CU0=$CU2)*($CV:$CV0=$CV2)*($CW:$CW0=$CW2)*($CX:$CX0=$CX2))>1,$CU2 <> "")
你为什么不把它转换成 Counti(S) 像下面这样的稳定引用？
=AND(COUNTIFS($A:$A0,$A2,$CU:$CU0,$CU2,$CV:$CV0,$CV2,$CW:$CW**0,$CW2,$CX:$CX0,$CX2)>1,$CU12<>"")
你说识别重复；我听到 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 Scripting Runtime 添加到VBE 的工具 ► 参考资料。
这可能像变魔术一样有效，但不确定是否有效。
您能否创建另一个支持性（临时）列，将所有四个条件串联起来？
ZZ_Temp = 连接（CS；CV；CZ；等）
我想这样，您可以 show/highlight 复制得更快。
条件格式和过滤
首先，您选择的函数不适合如此大量的行和多个条件。 A COUNTIFS function can perform many of the same multiple criteria operations that a SUMPRODUCT function can but in typically 25-35% of the calculation load and time. Additionally, full column references can be used without detriment in COUNTIFS as the column references are internally truncated at the limits of the Worksheet.UsedRange property.
您的标准公式可以用 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 函数实际上稍微缩短了计算时间。
Only Calculate When You Have To
原来的公式可以分解为两个主要条件。
- CT 列中的单元格是否为非空白？
- 五列中的值是否与任何其他行中的相同五列匹配？
如果条件不成立，基本的 IF function 会停止处理。如果将 CT 列中非空白单元格的测试移至环绕 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% 是空白的，则几乎看不到任何改进。但是，如果 CT 列中 50% 的单元格通常为空白，将会有实质性的改进，因为您实际上是在将计算周期减半。
Sorting the Data to Limit the Ranges
到目前为止，最大的计算寄生虫是 COUNTIFS 在五个单独的列中查看 15,000 行数据。如果数据是根据一个或多个条件列排序的，则无需查看所有 15,000 行以查找与所有五个条件列的匹配项。
For the purpose of this exercise, it will be assumed that column A is sorted in an ascending manner. If you want to test the hypothesis discussed here, sort the data now.
INDEX function does more than return a value; it actually returns a valid cell address. When used in its most common lookup capacity, you see the value returned but in reality, unlike a similar VLOOKUP操作只return单元格的值，INDEX是returning实际单元格；例如=A1，而不是 A1 包含的 99。这种超级功能可用于创建可在其他功能中使用的有效范围。例如A2:A9也可以写成INDEX(A:A, 2):INDEX(A:A, 9).
This functionality cannot be used directly within a Conditional Formatting rule. However, it can be used in a Named Range and a Named Range can be used in a Conditional Formatting rule.
tl;dr
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
虽然不会很快尖叫，但它可以轻松完成工作。 'best guess' 比 'definitive start and finish' 快，但你 运行 有不完全覆盖 A 列中重复项范围的风险。当然，偏移量（例如 100 上下）控制范围可调整