指定キーワードかつ、カラーカウント

投稿者 : けろ     投稿日時 : 2024/08/15(Thu) 21:45:29     OS : Windows 10     EXCEL : Excel 2013

---

たびたびすみません。
横型カレンダーを作っております。

横型カレンダーで、
A列に機械番号が入っています。↓の図で■がついているのは、実際は色がついています。

セルに色がついているのですが、colorcountというVBAを参考にさせていただいて色がついているセルの総カウント自体はできております。
ただ、できればA列で「機械A」かつ色がついている数、A列で「機械B」かつ色がついているセルの数、といった形でカウントをしたいです。
難しいでしょうか。


今はここまではできています。
↓
　　　　3　　6　　　5　　4　
　　　 8/1　 8/2　 8/3　 8/4
機械A　■　　■　　■　　■
機械B　■　　■　　
機械A　■　　■　　■　　■
機械A　　　　■　　■　　■
機械C　　　　■　　■　　■
機械B　　　　■　　■


セルには
=ColorCount(指定範囲:指定範囲,対象の色が塗りつぶされたセル)
が入っており、総数はカウントできております。

Function ColorCount(R1 As Range, C As Range) As Long

Dim r As Range

Application.ScreenUpdating = False
Application.Volatile  'ユーザー定義関数を自動再計算関数にします
ColorCount = 0  '初期値

    For Each r In R1
        If r.Interior.Color = C.Interior.Color Then  'セルの色をチェックします
            ColorCount = ColorCount + 1  'カウントの計算
        End If
    Next r

Application.ScreenUpdating = True

End Function

投稿者 : さんこう     投稿日時 : 2024/08/15(Thu) 22:55:05

---

＞難しいでしょうか。

条件を１つ追加するだけなので、難しいことはありません。

ただ、ユーザー定義関数とするには、その条件をどのように指定するかが考えどころになります。

そのあたりは省略していますが、参考になれば。

Sub CountCS()
    Dim R1 As Range
    Dim C As Long
    Set R1 = Range("B2:E7")         'カウント範囲
    C = Range("A1").Interior.Color  'カウント対象色
    
    Dim r As Range
    Dim cc As Long
    For Each r In R1
        If r.Interior.Color = C Then
            If Cells(r.Row, "A") = "機械A" Then
                cc = cc + 1
            End If
        End If
    Next
    
    MsgBox cc
End Sub

投稿者 : higeru     投稿日時 : 2024/08/16(Fri) 09:39:18

---

無理矢理（というほどでもないが）ユーザー定義関数にしてみました。
「機械A」などを参照する範囲（引数 R2）は、R1 と行範囲が同じであることとします（エラー判定もしています）。

Function ColorCount2(R1 As Range, C As Range, R2 As Range, mn As String) As Variant
    If R1.Rows.Count <> R2.Rows.Count Or R1(1).Row <> R2(1).Row Or mn = "" Then
        ColorCount2 = CVErr(xlErrRef)
        Exit Function
    End If
    Dim r As Range
    Application.ScreenUpdating = False
    Application.Volatile    'ユーザー定義関数を自動再計算関数にします
    ColorCount2 = 0 '初期値
        For Each r In R1
            If r.Interior.Color = C.Interior.Color Then 'セルの色をチェックします
                If Intersect(R2, Rows(r.Row)).Value = mn Then
                    ColorCount2 = ColorCount2 + 1       'カウントの計算
                End If
            End If
        Next r
    Application.ScreenUpdating = True
End Function

投稿者 : けろ     投稿日時 : 2024/08/16(Fri) 09:39:30

---

さんこう様の内容を引用して、Function自体少しアレンジしなおしたところできました！
ありがとうございます。助かりました。

ユーザー定義関数
=Countcolor(色がついた指定セル,列:列,キーワード)

Function CountColor(colorRng As Range, countRng As Range, keyword As String)

Dim cnt As Long 'カウントした数の箱
cnt = 0  '初期値

Dim check As Range 'チェックした数の箱

Application.Volatile  'ユーザー定義関数を自動再計算関数にします

    For Each check In countRng
    
        If check.Interior.Color = colorRng.Interior.Color Then  'セルの色をチェックします
           If Cells(check.Row, "A") = keyword Then
           cnt = cnt + 1  'カウントの計算
           End If
        End If
        
    Next check

CountColor = cnt

End Function