查找已填充任何颜色的所有单元格并在excel vba中突出显示相应的列标题

Question

我的问题：

我制作了一个大型（2,000行）宏，该宏在我们公司的模板上运行并修复了一些常见问题，并突出了我们在导入之前遇到的其他问题。模板文件总是有150列，在大多数情况下是15,000+行（有时甚至超过30,000）。宏工作得很好，根据我们的数据规则突出显示包含错误的所有单元格，但是对于包含这么多列和行的文件，我认为将一个片段添加到我的宏可以让它找到所有的已突出显示的单元格，然后突出显示包含这些突出显示的单元格的列的列标题。

我在搜索解决方案时找到的方法：

• SpecialCells xlCellTypeAllFormatConditions仅适用于条件格式，因此对我的情况来说这不是一种合理的方法

• 来自here的Rick Rothstein的UDF

  Sub FindYellowCells()
    Dim YellowCell As Range, FirstAddress As String
    Const IndicatorColumn As String = "AK"
    Columns(IndicatorColumn).ClearContents
    '   The next code line sets the search for Yellow color... the next line after it (commented out) searches
    '   for the ColorIndex 6 (which is usually yellow), so use whichever code line is applicable to your situation
    Application.FindFormat.Interior.Color = vbYellow
    'Application.FindFormat.Interior.ColorIndex = 6
    Set YellowCell = Cells.Find("*", After:=Cells(Rows.Count, Columns.Count), SearchFormat:=True)
    If Not YellowCell Is Nothing Then
      FirstAddress = YellowCell.Address
      Do
        Cells(YellowCell.Row, IndicatorColumn).Value = "X"
        Set YellowCell = Cells.Find("*", After:=YellowCell, SearchFormat:=True)
        If YellowCell Is Nothing Then Exit Do
      Loop While FirstAddress <> YellowCell.Address
    End If
  End Sub
  

  除了我们的文件可以有多个颜色填充之外，这将是一些完美的调整。由于我们的模板太大，我了解到运行Find的一个实例需要花费一些时间才能找到UsedRange中的一个颜色填充。

• 使用过滤，可以在所有列中循环，并检查每个列是否包含任何具有任何填充的单元格。那会更快吗？

所以，我的问题：

1. 如何找到包含任何颜色填充单元格的所有列？更具体地说，实现这一目标的最有效（最快）方法是什么？

Answer 1

性能最佳的解决方案是使用半间隔递归进行搜索。 从150列和30000行的工作表中标记列只需不到5秒钟。

搜索特定颜色的代码：

Sub TagColumns()
  Dim headers As Range, body As Range, col As Long, found As Boolean

  ' define the columns for the headers and body
  Set headers = ActiveSheet.UsedRange.Rows(1).Columns
  Set body = ActiveSheet.UsedRange.Offset(1).Columns

  ' iterate each column
  For col = 1 To headers.Count

    ' search for the yellow color in the column of the body
    found = HasColor(body(col), vbYellow)

    ' set the header to red if found, green otherwise
    headers(col).Interior.color = IIf(found, vbRed, vbGreen)
  Next

End Sub

Public Function HasColor(rg As Range, color As Long) As Boolean
  If rg.DisplayFormat.Interior.color = color Then
    HasColor = True
  ElseIf VBA.IsNull(rg.DisplayFormat.Interior.colorIndex) Then
    ' The color index is null so there is more than one color in the range
    Dim midrow&
    midrow = rg.Rows.Count \ 2
    If HasColor(rg.Resize(midrow), color) Then
      HasColor = True
    ElseIf HasColor(rg.Resize(rg.Rows.Count - midrow).Offset(midrow), color) Then
      HasColor = True
    End If
  End If
End Function

并搜索任何颜色：

Sub TagColumns()
  Dim headers As Range, body As Range, col As Long, found As Boolean

  ' define the columns for the headers and body
  Set headers = ActiveSheet.UsedRange.Rows(1).Columns
  Set body = ActiveSheet.UsedRange.Offset(1).Columns

  ' iterate each column
  For col = 1 To headers.Count

    ' search for any color in the column of the body
    found = VBA.IsNull(body(col).DisplayFormat.Interior.ColorIndex)

    ' set the header to red if found, green otherwise
    headers(col).Interior.color = IIf(found, vbRed, vbGreen)
  Next

End Sub

Answer 2

在：

运行这个短宏：

Sub FindingColor()
    Dim r1 As Range, r2 As Range, r As Range
    Dim nFirstColumn As Long, nLastColumn As Long, ic As Long

    Set r1 = ActiveSheet.UsedRange
    nLastColumn = r1.Columns.Count + r1.Column - 1
    nFirstColumn = r1.Column

    For ic = nFirstColumn To nLastColumn
        Set r2 = Intersect(r1, Columns(ic))
        For Each r In r2
            If r.Interior.ColorIndex <> xlNone Then
                r2(1).Interior.ColorIndex = 27
                Exit For
            End If
        Next r
    Next ic

End Sub

产生

我只是不知道速度问题。如果有色单元格靠近列的顶部，则代码将以超快的速度运行;如果有色细胞缺失或靠近色谱柱底部，则不是那么多。

修改＃1：

请注意，我的代码无法找到有条件的彩色单元格。

Answer 3

Range.Value property实际上有三个潜在的可选xlRangeValueDataType参数。默认值为 xlRangeValueDefault ，这是大多数人使用的所有（通过省略）。

xlRangeValueXMLSpreadsheet 选项检索XML数据块，该数据块描述了单元格维护的许多属性。除xlAutomatic之外没有Range.Interior属性的单元格将具有以下XML元素

<Interior/>

...具有.Interior.Color属性的单元格将具有以下XML元素

<Interior ss:Color="#FF0000" ss:Pattern="Solid"/>

已经确定将工作表的值转储到变量数组中并在内存中处理比循环遍历单元格要快得多，因此检索.Value(xlRangeValueXMLSpreadsheet)并在XML的单个blob上执行InStr function数据应该证明更快。

Sub filledOrNot()
    Dim c As Long, r As Long, vCLRs As String

    appTGGL bTGGL:=False

    With Worksheets("30Kdata")
        With .Cells(1, 1).CurrentRegion
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                For c = 1 To .Columns.Count
                    vCLRs = .Columns(c).Cells.Value(xlRangeValueXMLSpreadsheet)
                    If CBool(InStr(1, vCLRs, "<Interior ss:Color=", vbBinaryCompare)) Then _
                        .Cells(0, c).Interior.Color = 49407
                Next c
            End With
        End With
        Debug.Print Len(vCLRs)
    End With

    appTGGL

End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .DisplayAlerts = bTGGL
        .AutoRecover.Enabled = bTGGL   'no interruptions with an auto-save
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
        .CutCopyMode = False
        .StatusBar = vbNullString
    End With
    Debug.Print Timer
End Sub

我用30列30K行运行它。在检查每个列的同时，我只在每个第三列播种了一个.Interior.Color属性，该属性在30K行内随机。花了大约一分半钟。

每行30K行产生的XML记录大小几乎为3Mbs;典型的长度为2,970,862。一旦读入变量，就会搜索设定内部填充的指纹。

将读取放入字符串类型var并直接在.Value（xlRangeValueXMLSpreadsheet）上执行InStr实际上将时间缩短了大约两秒钟。

Answer 4

我的提案使用AutoFilter对象的Range方法

它运行得非常快

Option Explicit

Sub FilterByFillColor()
Dim ws As Worksheet
Dim headerRng As Range
Dim iCol As Long, RGBColor As Long

Set ws = ThisWorkbook.Worksheets("HeadersToColor") '<== set it to your actual name of the data worksheet
Set headerRng = ws.Range("headers") '<== I set a named range "headers" in my test sheet addressing the cells that cointains all headers. but you may use explicit address ie: 'ws.Range("B2:EU150")' for a 150 columns header range
RGBColor = RGB(255, 0, 0)

Application.ScreenUpdating = False
headerRng.Interior.Color = vbGreen
With headerRng.CurrentRegion
    For iCol = 1 To .Columns.Count
        .AutoFilter Field:=iCol, Criteria1:=RGBColor, Operator:=xlFilterNoFill
        If .Columns(iCol).SpecialCells(xlCellTypeVisible).Count < .Rows.Count Then headerRng(iCol).Interior.Color = vbRed
        .AutoFilter
    Next iCol
End With
Application.ScreenUpdating = True

End Sub