【VBA】文字色を判定してカウントする【Font.Colorを使う】

Sub TEST1()
  
  Dim A, Cn
  Cn = 0 '初期値
  
  '表をループ
  For Each A In Range("A1").CurrentRegion
    '文字色が赤の場合
    If A.Font.Color = vbRed Then
      Cn = Cn + 1 'カウントアップ
    End If
  Next
  
  Debug.Print "赤は、" & Cn & " 個です"
  
End Sub

Sub TEST2()
  
  Dim A, Cn1, Cn2, Cn3
  Cn1 = 0 '赤の初期値
  Cn2 = 0 '緑の初期値
  Cn3 = 0 '青の初期値
  
  '表をループ
  For Each A In Range("A1").CurrentRegion
    '文字色が赤の場合
    If A.Font.Color = vbRed Then
      Cn1 = Cn1 + 1
    '文字色が緑の場合
    ElseIf A.Font.Color = vbGreen Then
      Cn2 = Cn2 + 1
    '文字色が青の場合
    ElseIf A.Font.Color = vbBlue Then
      Cn3 = Cn3 + 1
    End If
  Next
  
  Debug.Print "赤は、" & Cn1 & " 個です"
  Debug.Print "緑は、" & Cn2 & " 個です"
  Debug.Print "青は、" & Cn3 & " 個です"
  
End Sub

Sub TEST3()
  
  Dim Dic
  '辞書を作成
  Set Dic = CreateObject("Scripting.Dictionary")
  
  Dim A
  For Each A In Range("A1").CurrentRegion
    '登録されていない場合は登録
    If Dic.exists(A.Font.Color) = False Then
      Dic.Add A.Font.Color, 1
    '登録されている場合はカウントアップ
    Else
      Dic(A.Font.Color) = Dic(A.Font.Color) + 1
    End If
  Next
  
  Dim B, C
  'キーを入力
  Range("C2").Resize(Dic.Count) = WorksheetFunction.Transpose(Dic.keys)
  'アイテムを入力
  Range("D2").Resize(Dic.Count) = WorksheetFunction.Transpose(Dic.Items)
  
  '文字色を変更
  For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
    Cells(i, "C").Font.Color = Cells(i, "C")
  Next
  
End Sub