計數多種顏色在多個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