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

Question

我的问题：

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

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

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

来自 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.

[= 中找到一个颜色填充47=]

使用过滤，可能循环遍历所有列并检查每个列是否包含具有任何颜色填充的单元格。那样会更快吗？

那么，我的问题是：

我怎样才能找到包含 any colorfilled 单元格的所有列？更具体地说，实现此目标的最有效（最快）方法是什么？

Answer 1

之前：

运行这个简短的宏：

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 2

Range.Value property actually has three potential optional xlRangeValueDataType参数。默认值是 xlRangeValueDefault，这就是大多数人曾经使用过的全部（由于遗漏）。

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

<Interior/>

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

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

众所周知，将工作表的值转储到变体数组中并处理 in-memory 比遍历单元格要快得多，因此检索 .Value(xlRangeValueXMLSpreadsheet) 并执行 InStr function XML 数据的单个 blob 应该会更快。

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

我运行这是针对 30K 行乘 26 列的。在检查每一列时，我只在每三列的 30K 行内的某个地方运行放置了一个 .Interior.Color 属性。大约花了一分半钟。

每列 30K 行产生一个 XML 大小接近 3Mbs 的记录；典型的长度为 2,970,862。一旦读入一个变量，它就会搜索一组内部填充的指纹。

放弃对字符串类型 var 的读取并直接在 .Value(xlRangeValueXMLSpreadsheet) 上执行 InStr 实际上将时间缩短了大约两秒。

Answer 3

最高效的解决方案是使用半间隔递归进行搜索。从具有 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 4

我的建议使用 Range 对象的 AutoFilter 方法

运行速度相当快

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

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

Finding all cells that have been filled with any color and highlighting corresponding column headers in excel vba

excel

vba

user-defined-functions