Vba 对每列中的彩色单元格进行计数并返回计数

我一直在试图找到一种更简单的方法来返回每列彩色单元格的数量。到目前为止，我的代码是：

Sub errors()

Dim Sheet1 As String
Dim mycell As Range
Dim datecol As Long
Dim col As Long

Sheet1 = "different"    

For Each mycell In ActiveWorkbook.Worksheets(shtSheet1).Range("B:B")
    If mycell.Interior.Color = vbRed Then
        datecol = datecol + 1
End If
Next mycell

Debug.Print datecol

End Sub

---

如果我有40个列，这是相当乏味和缓慢的，有没有更好的方法来做到这一点（在学习vba方面非常新），因此我会为每个循环重复几个，并指定列。我需要帮助改进代码或使用新方法返回每列彩色单元格的数量。

您的方法很好，但可以改进-

Sub test()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim cntclr As Integer
cntclr = 0
For i = 1 To lastrow
    If Cells(i, 1).Interior.Color = vbRed Then
        cntclr = cntclr + 1
    End If
Next
MsgBox (cntclr)
End Sub

如果要对每个列执行此操作，则可以执行此操作并打印结果，只需更改数组填充的范围即可

Sub test()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column

Dim arr() As String
ReDim arr(1 To lastcol, 1)
Dim cntClr As Integer
Dim strCol As String
Dim strCnt As String

For j = 1 To lastcol

    cntClr = 0
    For i = 1 To lastrow
    If Cells(i, j).Interior.Color = vbRed Then
        cntClr = cntClr + 1
    End If
    Next
    strCol = "Col " & Chr(64 + j)
    strCnt = Str(cntClr)
    arr(j, 0) = strCol
    arr(j, 1) = cntClr

Next
Range("D1:E" & lastcol) = arr()
End Sub

使用

---

为什么不在另一个循环中循环for each循环以遍历您需要的所有列？您真的需要检查列中的每个（通常）1048576单元格吗？或者——仅仅是实际使用的细胞？另外——如果单元格颜色是由条件格式造成的——为什么不直接计算满足条件的单元格？@JohnColeman我只是想计算所用数据行中的彩色单元格。我正在尝试分解每个列标题的摘要，以便快速修复任何错误。@Tony类似于范围（单元格（1,2）、单元格（行数，2）.End（xlUp））的方法是将范围设置在包含所有实际有值的单元格的列顶部。请注意，2可以替换为一个变量，该变量逐步遍历循环中的一系列列。但是，当我调整范围并删除“Col”&Chr（64+j）”时，您的第二个解决方案非常好。它会生成一个数字列表，然后生成一个“n/a”列表“为什么要删除列和字符？它是数组的字符串，用于获取列号并将其转换为字母。如果不是从A开始，只需将64改为更大的数字。或者从正确的列开始J。我已经有了要与数组中的数字关联的列列表，因此我不需要显示“Col A”等。但是，当我将Range（“D1:E”&lastcol）=arr（）更改为D10时，它会在数组之后生成一个“n/A”列表。您需要将数组尺寸调整为单个（垂直）数组并仅打印计数。可以将其设置为整数数组而不是字符串。如果要打印计数的特定范围，则根本不需要该数组-可以在计数循环后直接打印。如果您需要这方面的帮助，只需告诉我输出范围在哪里，以及您实际需要帮助的列，但我相信您可能可以解决这部分问题。

Sub errors()

    Dim Sheet1 As String
    Dim mycell As Range
    Dim datecol As Long
    Dim col As Long

    Sheet1 = "different"

    Dim ws As Worksheet, lastrow As Long
    Dim myrng as Range
    Set ws = ActiveWorkbook.Sheets(Sheet1)
    lastrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    ' If you think you may have colored cells with no data
    ' Set myrng = ws.UsedRange.Rows
    ' lastrow = myrng(myrng.Count).Row

    Set myrng = ws.Range("B1:B" & lastrow)
    For Each mycell In myrng
        If mycell.Interior.Color = vbRed Then
            datecol = datecol + 1
        End If
    Next mycell

    Debug.Print datecol

End Sub