使用VBA在excel中进行范围广泛的条件格式化 [英] Conditional formatting over huge range in excel, using VBA

问题描述

我有一本excel工作簿，在给定的列中大约有3万行.我需要交叉验证另一个同样庞大的列表，以查看是否有任何匹配项.如果是这样，那么我希望它突出显示该单元格.

如其他主题所建议，我手动记录了宏，代码为:

  Sheets("Main").选择列("D:D").选择Selection.FormatConditions.Add类型:= xlTextString，字符串:= _"= list1！$ A $ 1"，TextOperator:= xl包含Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority带有Selection.FormatConditions(1).Interior.PatternColorIndex = xl自动颜色= 65535.TintAndShade = 0结束于 

此宏有效，但仅适用于包含我要验证的庞大列表的其他工作表中的第一个单元格.但是，我无法将其用于其他49999行.此外，该列表在另一张表中.

我尝试创建一个for循环，例如 for i = 1到列的长度，这样做 但每次都失败了.

在OP关于CF方法相对于其他方法的问题之后，

解决方案

编辑

edited2 :添加了词典"方法

条件格式"方法可能比范围"方法更快，但是前者还可以使工作表在以后的使用中非常繁重和慢.更不用说我在CF细胞过多之后也有崩溃的经历

词典"方法都是最快的

在此遵循上述所有方法的可能代码

---

"CF"方法

如果您真的 必须使用条件格式，并且如果我正确理解了您的目标，请尝试以下(注释)代码:

 选项显式子main()Dim mainRng作为范围，list1Rng作为范围设置mainRng = GetRange(Worksheets("Main")，"D")'<-|从第1行到最后一个非空行获取主要"工作表列"D"的范围设置list1Rng = GetRange(Worksheets("list1")，"A")'<-|从第1行到最后一个非空行获取"list1"工作表列"D"的范围AddCrossCountFormatCondition mainRng，list1Rng'<-||将交叉验证从主"添加到"List1"工作表AddCrossCountFormatCondition list1Rng，mainRng'<-||将交叉验证从"List1"添加到主"工作表结束子函数GetRange(ws作为工作表，colIndex作为字符串)作为范围与ws'<-|参考传递的工作表设置GetRange = .Range(colIndex&"1"，.Cells(.Rows.Count，colIndex).End(xlUp))'<-|将其列"colIndex"的范围设置为从第1行到最后一个非空行结束于结束功能Sub AddCrossCountFormatCondition(rng1作为范围，rng2作为范围)与rng1Intersect(rng1.Parent.UsedRange，rng1.Resize(1，1).EntireColumn).FormatConditions.Delete'<-|删除以前的条件格式.FormatConditions.Add类型:= xlExpression，Formula1:= _"= COUNTIF("& rng2.Parent.Name&！"& rng2.Address&，concatenate(""*"，"& rng1.Resize(1，1).Address(False，False)&，""*"))> 0".FormatConditions(.FormatConditions.Count).SetFirstPriority使用.FormatConditions(1).Interior.PatternColorIndex = xl自动颜色= 65535.TintAndShade = 0结束于结束于结束子 

---

范围"方法

 选项显式子main2()Dim mainRng作为范围，list1Rng作为范围设置mainRng = getRange(Worksheets("Main")，"D")'<-|从第1行到最后一个非空行获取主要"工作表列"D"的范围设置list1Rng = getRange(Worksheets("list1")，"A")'<-|从第1行到最后一个非空行获取"list1"工作表列"D"的范围ColorMatchingRange mainRng，list1RngColorMatchingRange list1Rng，mainRng结束子子ColorMatchingRange(rng1作为范围，rng2作为范围)Dim unionRng作为范围，像元作为范围，f作为范围设置unionRng = rng1.Offset(，rng1.Columns.Count).Resize(1，1)对于rng1中的每个单元格如果WorksheetFunction.CountIf(rng2，"*"& cell.Value&"*")>0然后设置unionRng = Union(unionRng，cell)下一个单元格设置unionRng =相交(unionRng，rng1)如果没有unionRng则什么也没有使用unionRng.Interior.PatternColorIndex = xl自动颜色= 65535.TintAndShade = 0结束于万一结束子函数getRange(ws作为工作表，colIndex作为字符串)作为范围与ws'<-|参考传递的工作表设置getRange = .Range(colIndex&"1"，.Cells(.Rows.Count，colIndex).End(xlUp))'<-|将其列"colIndex"的范围设置为从第1行到最后一个非空行结束于结束功能 

---

词典"方法

 选项显式子main3()Dim mainRng作为范围，list1Rng作为范围Dim mainDict作为新脚本.Dictionary，list1Dict作为新脚本.设置mainRng = getRange(Worksheets("Main")，"D")'<-|从第1行到最后一个非空行获取主要"工作表列"D"的范围设置list1Rng = getRange(Worksheets("list1")，"A")'<-|从第1行到最后一个非空行获取"list1"工作表列"D"的范围设置mainDict = GetDictionary(mainRng)设置list1Dict = GetDictionary(list1Rng)ColorMatchingRange2 mainRng，mainDict，list1DictColorMatchingRange2 list1Rng，list1Dict，mainDict结束子Sub ColorMatchingRange2(rng1作为范围，dict1作为Scripting.Dictionary，dict2作为Scripting.Dictionary)昏暗的UnionRng作为范围昏暗的瓦尔斯作为变体昏暗的我只要vals = Application.Transpose(rng1.Value)设置unionRng = rng1.Offset(，rng1.Columns.Count).Resize(1，1)对于i = LBound(vals)到UBound(vals)如果dict2.Exists(vals(i))然后设置unionRng = Union(unionRng，rng1(i，1))接下来我设置unionRng =相交(unionRng，rng1)如果没有unionRng则什么也没有使用unionRng.Interior.PatternColorIndex = xl自动颜色= 65535.TintAndShade = 0结束于万一结束子函数GetDictionary(rng作为范围)如Scripting.DictionaryDim dict作为新脚本昏暗的瓦尔斯作为变体昏暗的我只要vals = Application.Transpose(rng.Value)关于错误继续对于i = LBound(vals)到UBound(vals)dict.Add vals(i)，rng(i，1).地址接下来我出错时转到0设置GetDictionary = dict结束功能函数getRange(ws作为工作表，colIndex作为字符串)作为范围与ws'<-|参考传递的工作表设置getRange = .Range(colIndex&"1"，.Cells(.Rows.Count，colIndex).End(xlUp))'<-|将其列"colIndex"的范围设置为从第1行到最后一个非空行结束于结束功能 

I have an excel workbook that has about 30k rows in a given column. I need to cross validate another equally huge list to see if there are any matches. If so, then I want it to highlight that cell.

As suggested in other threads, I recorded the macro manually and the code is:

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

This macro works but only for the first cell in the other sheet that contains the huge list I want to validate. However, I can't get it to work for the other 49999 rows. Moreover, this list is in another sheet.

I tried creating a for loop, like for i = 1 to length of column, do this but failed miserably every time.

解决方案

edited after OP's question about CF approach versus other ones

edited2: added "dictionary" approach

"Conditional formatting" approach can be quicker than the "Range" one, but the former can also make worksheet very heavy and slow in subsequent use. not to mention I also had crash down experiences after too many CF cells

"Dictionary" approach is both quickest

here follow possible codes for all above mentioned approaches

---

"CF" approach

If you really must use conditional formatting and if I correctly undestood your aim, then try this (commented) code:

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

---

"Range" approach

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

---

"Dictionary" approach

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

这篇关于使用VBA在excel中进行范围广泛的条件格式化的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！