计数多种颜色在多个Excel文件的VBA

Question

我有多个Excel其中有黄色和红色的颜色来填充在一些细胞中的文件夹中

我需要一个excel记录，这将产生在每个提交的黄色文件名计数对应于该

例如Excel中：

文件名黄色红色

1.xlsx 13 14 2.xlsx 5 10

任何人都可以帮助我。

Answer 1

这会将您的红色和黄色单元格记录在运行此代码的工作簿中名为“日志表”的工作表中。添加/命名此工作表以及您需要的任何格式。获取有条件格式化单元格的单元格颜色非常棘手，但您可以在this article中找到帮助。我在日志表中包含了一列，以确定工作表中是否有条件格式化的单元格，但没有分析或计数。我还包括一个包含工作表选项卡名称的列。

此代码分析工作表UsedRange内的单元格颜色。您需要在变量dataFileFolder中输入数据文件的路径。

Sub countYellowRedCells() 
Dim wbk As Variant 
Dim wsLog As Worksheet, sht As Worksheet 
Dim cCell As Range 
Dim cfFlag As Boolean 
Dim dataFileFolder As String 
Dim redCount As Long, yellowCount As Long 
Dim logRowEnd As Long, logCol As Long 

Set wsLog = ThisWorkbook.Sheets("Log Sheet") 

logCol = 2 
redCount = 0 
yellowCount = 0 
cfFlag = False 

dataFileFolder = "C:\......TestFiles\" 'ENTER YOUR PATH 

Application.ScreenUpdating = False 

wbk = Dir(dataFileFolder) 

    Do Until wbk = "" 
     Workbooks.Open dataFileFolder & wbk 
      For Each sht In ActiveWorkbook.Worksheets 
       For Each cCell In sht.UsedRange 
        If cCell.FormatConditions.count <> 0 Then cfFlag = True 
        Select Case cCell.Interior.Color 
         Case Is = RGB(255, 0, 0) 
          redCount = redCount + 1 
         Case RGB(255, 255, 0) 
          yellowCount = yellowCount + 1 
        End Select 
       Next cCell 

       With wsLog 
        logRowEnd = .Cells(Rows.count, logCol).End(xlUp).Row 
        .Cells(logRowEnd, logCol).Offset(1, 0).Value = ActiveWorkbook.Name 
        .Cells(logRowEnd, logCol).Offset(1, 1).Value = sht.Name 
        .Cells(logRowEnd, logCol).Offset(1, 2).Value = yellowCount 
        .Cells(logRowEnd, logCol).Offset(1, 3).Value = redCount 
        .Cells(logRowEnd, logCol).Offset(1, 4).Value = cfFlag 
       End With 

       'MsgBox (ActiveWorkbook.Name & " - Sheet: " & sht.Name & Chr(10) _ 
       & redCount & " Red cells." & Chr(10) & yellowCount & " Yellow cells.") 
       redCount = 0 
       yellowCount = 0 
       cfFlag = False 
      Next sht 
     Workbooks(wbk).Close savechanges:=False 
     wbk = Dir 
    Loop 

Application.ScreenUpdating = True 

End Sub