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

问题

My problem:

I've made a large (2,000 line) macro that runs on our company's template and fixes some common issues and highlights other issues we have prior to importing. The template file always has 150 columns and is in most instances 15,000+ rows (sometimes even over 30,000). The macro works well, highlighting all the cells that contain errors according to our data rules, but with a file with so many columns and rows I thought it'd be convenient to add a snippet to my macro that would have it find all of the cells that have been highlighted and then highlight the column headers of the columns that contain those highlighted cells.

Methods I've found while searching for a solution:

• SpecialCellsxlCellTypeAllFormatConditions only works for conditional formatting, so that isn't a plausible method for my situation

• Rick Rothstein's UDF from here

  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
  

  This would be perfect with a few tweaks, except our files can have multiple colorfills. Since our template is so large I've learned that it takes quite some time to run one instance of Find to find just one colorfill in the UsedRange.

• Using filtering, maybe cycling through all the columns and checking each if they contain any cell that has any colorfill. Would that be any faster though?

So, my question:

1. How could I accomplish finding all columns that contain any colorfilled cells? More specifically, what would be the most efficient (fastest) way to achieve this?

回答1:

The most performant solution would be to search using recursion by half-interval. It takes less than 5 seconds to tag the columns from a worksheet with 150 columns and 30000 rows.

The code to search for a specific color:

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

And to search for any color:

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

回答2:

Before:

Running this short macro:

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

produces:

I just don't know about the speed issue. If the colored cells are near the top of the column, the code will run super fast; if the colored cells are missing or near the bottom of the column, not so much.

EDIT#1:

Please note that my code will not find cells colored conditionally.

回答3:

The Range.Value property actually has three potential optional xlRangeValueDataType parameters. The default is xlRangeValueDefault and that is all (by omission) most anyone ever uses.

The xlRangeValueXMLSpreadsheet option retrieves an XML data block which describes many of the properties that the cell maintains. A cell with no Range.Interior property beyond xlAutomatic will have the following XML element,

<Interior/>

... while a cell with an .Interior.Color property will have the following XML element,

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

It's been well established that dumping a worksheet's values into a variant array and processing in-memory is substantially quicker than looping through cells so retrieving the .Value(xlRangeValueXMLSpreadsheet) and performing an InStr function on the single blob of XML data should prove much faster.

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

I ran this against 30K rows by 26 columns. While each column was examined, I had only seeded every third column with an .Interior.Color property somewhere randomly within the 30K rows. It took about a minute and a half.

Each column of 30K rows produced an XML record that was almost 3Mbs in size; a length of 2,970,862 was typical. Once read into a variable, it was searched for the fingerprint of a set interior fill.

    

Discarding the read into the string type var and performing the InStr directly on the .Value(xlRangeValueXMLSpreadsheet) actually improved the time by about two seconds.

回答4:

My proposal using AutoFilter method of Range object

it runs quite fast

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

来源：https://stackoverflow.com/questions/35975076/finding-all-cells-that-have-been-filled-with-any-color-and-highlighting-correspo