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

我的问题：

我制作了一个大的（2000行）macros，运行在我们公司的模板上，修复了一些常见问题，并突出显示了导入前的其他问题。 模板文件总是有150列，在大多数情况下是15000+行（有时甚至超过30000）。 macros运行良好，根据我们的数据规则突出显示所有包含错误的单元格，但是具有如此多列和行的文件我认为将代码段添加到我的macros中会很方便，已高亮的单元格，然后突出显示包含突出显示的单元格的列的列标题。

我在search解决scheme时发现的方法：

• SpecialCells xlCellTypeAllFormatConditions只适用于条件格式，所以这不是我的情况似是而非的方法

• 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中find一个颜色UsedRange 。

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

所以，我的问题是：

1. 我怎么能find所有包含任何填充颜​​色的单元格的列？ 更具体地说，实现这个目标的最有效（最快）的方法是什么？

Answer 1

性能最好的解决scheme是使用半间隔的recursionsearch。 使用150列和30000行标记工作表中的列需要不到5秒的时间。

search特定颜色的代码：

 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 

并search任何颜色：

 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

之前：

运行这个简短的macros：

 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：

请注意，我的代码不会有条件地find单元格。

Answer 3

Range.Value属性实际上有三个可能的可选的xlRangeValueDataType参数。 默认值是xlRangeValueDefault ，这是大多数人曾经使用过的（通过省略）。

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

 <Interior/> 

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

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

将工作表的值转储到variables数组中并处理内存要比循环遍历单元快得多，因此检索.Value(xlRangeValueXMLSpreadsheet)并在单个XML数据块上执行InStr函数应该快得多。

 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列。 在检查每一列的同时，我只在第三列中随机select了一个.interior.Color属性，这个属性随机在30K行内。 花了大约一分半钟。

每行30K行产生了一个几乎是3Mbs的XMLlogging; 典型的长度为2,970,862。 一旦读入variables，就会search设置的内部填充的指纹。

放弃读入stringtypesvar并直接在.Value（xlRangeValueXMLSpreadsheet）上执行InStr实际上将时间缩短了大约两秒钟。

Answer 4

我的build议使用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