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

Question

我的问题：

我制作了一个大的（2,000行）宏，该宏运行在我们公司的模板上，并修复了一些常见问题并突出了导入之前我们遇到的其他问题。模板文件始终具有150列，并且在大多数情况下为15,000+行（有时甚至超过30,000）。宏效果很好，根据我们的数据规则突出显示了所有包含错误的单元格，但是对于一个具有如此多列和行的文件，我认为向我的宏添加一个代码段会很方便，因为它可以找到所有突出显示的单元格，然后突出显示包含那些突出显示的单元格的列的列标题。

我在寻找解决方案时发现的方法：

• SpecialCellsxlCellTypeAllFormatConditions仅适用于条件格式，因此对于我的情况而言，这不是可行的方法

• 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