使用VBA在excel中进行大范围的条件格式化
我有一个excel工作簿，在给定的列中有大约30k行。 我需要交叉validation另一个同样巨大的列表，看看是否有任何匹配。 如果是的话，那么我想让它突出显示那个单元格。
正如其他线程所build议的，我手动logging了这个macros，代码是：
Sheets("Main").Select Columns("D:D").Select Selection.FormatConditions.Add Type:=xlTextString, String:= _ "=list1!$A$1", TextOperator:=xlContains Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 End With 这个macros的工作原理，但只为包含我想要validation的巨大列表的其他工作表中的第一个单元格。 但是，我不能让它为其他49999行工作。 而且，这个清单是在另一张表格中。
我试图创build一个for循环，像for i = 1 to length of column ，这样做，但每次失败悲惨。
在OP关于CF方法和其他方法的问题之后进行编辑
edited2 ：增加了“字典”的方法
“条件格式”的方法可能比“范围”更快，但前者也可能使工作表在后续使用中变得非常沉重和缓慢 。 更不用说我也经历了太多的CF单元的崩溃
“字典”的做法是最快的
这里遵循所有上述方法的可能的代码
“CF”方法
如果你真的 必须使用条件格式，并且如果我正确地拒绝你的目标，那么试试这个（注释）代码：
Option Explicit Sub main() Dim mainRng As Range, list1Rng As Range Set mainRng = GetRange(Worksheets("Main"), "D") '<--| get "Main" sheet column "D" range from row 1 down to last non empty row Set list1Rng = GetRange(Worksheets("list1"), "A") '<--| get "list1" sheet column "D" range from row 1 down to last non empty row AddCrossCountFormatCondition mainRng, list1Rng '<--| add cross validation from "Main" to "List1" worksheet AddCrossCountFormatCondition list1Rng, mainRng '<--| add cross validation from "List1" to "Main" worksheet End Sub Function GetRange(ws As Worksheet, colIndex As String) As Range With ws '<--| reference passed worksheet Set GetRange = .Range(colIndex & "1", .Cells(.Rows.Count, colIndex).End(xlUp)) '<--| set its column "colIndex" range from row 1 down to last non empty row End With End Function Sub AddCrossCountFormatCondition(rng1 As Range, rng2 As Range) With rng1 Intersect(rng1.Parent.UsedRange, rng1.Resize(1, 1).EntireColumn).FormatConditions.Delete '<--| remove previous conditional formatting .FormatConditions.Add Type:=xlExpression, Formula1:= _ "=COUNTIF(" & rng2.Parent.Name & "!" & rng2.Address & ",concatenate(""*""," & rng1.Resize(1, 1).Address(False, False) & ",""*""))>0" .FormatConditions(.FormatConditions.Count).SetFirstPriority With .FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 End With End With End Sub
“范围”方法
Option Explicit Sub main2() Dim mainRng As Range, list1Rng As Range Set mainRng = getRange(Worksheets("Main"), "D") '<--| get "Main" sheet column "D" range from row 1 down to last non empty row Set list1Rng = getRange(Worksheets("list1"), "A") '<--| get "list1" sheet column "D" range from row 1 down to last non empty row ColorMatchingRange mainRng, list1Rng ColorMatchingRange list1Rng, mainRng End Sub Sub ColorMatchingRange(rng1 As Range, rng2 As Range) Dim unionRng As Range, cell As Range, f As Range Set unionRng = rng1.Offset(, rng1.Columns.Count).Resize(1, 1) For Each cell In rng1 If WorksheetFunction.CountIf(rng2, "*" & cell.Value & "*") > 0 Then Set unionRng = Union(unionRng, cell) Next cell Set unionRng = Intersect(unionRng, rng1) If Not unionRng Is Nothing Then With unionRng.Interior .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 End With End If End Sub Function getRange(ws As Worksheet, colIndex As String) As Range With ws '<--| reference passed worksheet Set getRange = .Range(colIndex & "1", .Cells(.Rows.Count, colIndex).End(xlUp)) '<--| set its column "colIndex" range from row 1 down to last non empty row End With End Function
“字典”的做法
Option Explicit Sub main3() Dim mainRng As Range, list1Rng As Range Dim mainDict As New Scripting.Dictionary, list1Dict As New Scripting.Dictionary Set mainRng = getRange(Worksheets("Main"), "D") '<--| get "Main" sheet column "D" range from row 1 down to last non empty row Set list1Rng = getRange(Worksheets("list1"), "A") '<--| get "list1" sheet column "D" range from row 1 down to last non empty row Set mainDict = GetDictionary(mainRng) Set list1Dict = GetDictionary(list1Rng) ColorMatchingRange2 mainRng, mainDict, list1Dict ColorMatchingRange2 list1Rng, list1Dict, mainDict End Sub Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary) Dim unionRng As Range Dim vals As Variant Dim i As Long vals = Application.Transpose(rng1.Value) Set unionRng = rng1.Offset(, rng1.Columns.Count).Resize(1, 1) For i = LBound(vals) To UBound(vals) If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(i, 1)) Next i Set unionRng = Intersect(unionRng, rng1) If Not unionRng Is Nothing Then With unionRng.Interior .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 End With End If End Sub Function GetDictionary(rng As Range) As Scripting.Dictionary Dim dict As New Scripting.Dictionary Dim vals As Variant Dim i As Long vals = Application.Transpose(rng.Value) On Error Resume Next For i = LBound(vals) To UBound(vals) dict.Add vals(i), rng(i, 1).Address Next i On Error GoTo 0 Set GetDictionary = dict End Function Function getRange(ws As Worksheet, colIndex As String) As Range With ws '<--| reference passed worksheet Set getRange = .Range(colIndex & "1", .Cells(.Rows.Count, colIndex).End(xlUp)) '<--| set its column "colIndex" range from row 1 down to last non empty row End With End Function