【エクセルマクロ】色付きセルをカウント２選：動画あり

エクセルマクロで、色つきセルをカウントするVBAコードをご紹介します。

このページのマクロコードは、コピペで使えます。
ぜひお試しください！

色付きセルをカウント

以下のマクロを実行すると、色付きのセルを数えます。

Sub セルの色をカウント()

    Dim Rng As Range
    Dim Red_cnt As Long
    Dim yellow_cnt As Long
    Dim Green_cnt As Long

    For Each Rng In Range("A2:G6")
        Select Case Rng.Interior.ColorIndex
        
            '赤色
            Case 3
                Red_cnt = Red_cnt + 1
                
            '黄色
            Case 6
                yellow_cnt = yellow_cnt + 1
        
            '緑色
            Case 43
                Green_cnt = Green_cnt + 1
        
        End Select
    Next Rng
    
    Range("J2") = Red_cnt
    Range("J3") = yellow_cnt
    Range("J4") = Green_cnt
 
End Sub

マクロ実行後

色のついたセルの数をカウントし、結果をJ列に転記しました。

[Select Case] を使って、色ごとのセルを数えています。

色付きセルをカウント（配列使用）

以下のマクロを実行すると、連想配列を使用して色がついたセルを数えます。

Sub 連想配列を使用してセルの色をカウント()
 
Dim myDic As Object
Dim myKey As Variant
Dim i As Long
Dim j As Long
Dim Q As Long
Dim LastRow As Long
Dim LastColm As Long
     
    '連想配列
    Set myDic = CreateObject("Scripting.Dictionary")

    '行・列の最終行を取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    LastColm = Cells(1, Columns.Count).End(xlToLeft).Column
      
    '行をループ
    For i = 1 To LastRow
    
      '列をループ
      For j = 1 To LastColm
         
        '重複しない色を連想配列へ格納
        If Not myDic.Exists(Cells(i, j).Interior.Color) Then
          myDic.Add Cells(i, j).Interior.Color, Cells(i, 1).Interior.Color
　　　　 End If
        
      Next j
    Next
    
    '重複していない色を格納
    myKey = myDic.Keys

    Application.ScreenUpdating = False

    '重複していない色をループ
    For i = 0 To UBound(myKey)
    
        'I列に色を塗る
        Cells(i + 1, 9).Interior.Color = myKey(i)
    
        '行をループ
        For j = 1 To LastRow
        
            '列をループ
            For Q = 1 To LastColm
            
                If Cells(j, Q).Interior.Color = myKey(i) Then
                
                    'J列に色数をカウント
                    Cells(i + 1, 10) = Cells(i + 1, 10) + 1
                
                End If

            Next Q
        Next j
    Next

    Application.ScreenUpdating = True

    '開放
    Set myDic = Nothing

End Sub

マクロ実行後

・範囲内（A1：G6）で使用しているすべての色を取得し、I列に取得した色を塗ります。
・I列の色が範囲内（A1：G6）で何個塗られているかカウントして、J列にセル数を転記します。

 
 
この記事がお役に立ちますと幸いです。
 

エクセルマクロ 文字色が付いているセルをカウント(動画あり)

...

kirinote.com

2023.07.17