VBA Dictionary (COUNTIFSのように集計)

２つの条件で集計する

セル直接版

Sub CountQualifications()
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet4")
    
    Dim dictAll As Object, dictGrp As Object
    Set dictAll = CreateObject("Scripting.Dictionary")
    dictAll.CompareMode = vbTextCompare

    Dim lastRow As Long
    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
        .Range("F:H").ClearContents
        .Range("F1").Value = "班"
        .Range("G1").Value = "名前"
        .Range("H1").Value = "資格数"
        
        If lastRow < 2 Then
            MsgBox "データがありません。", vbInformation
            Exit Sub
        End If
    End With

    Dim i As Long
    Dim grp As String, name As String
    Dim qual1 As String, qual2 As String

    ' --- 集計（資格カウント） ---
    For i = 2 To lastRow
    
        grp = Trim(ws.Cells(i, 1).Value)
        name = Trim(ws.Cells(i, 2).Value)
        qual1 = Trim(ws.Cells(i, 3).Value)
        qual2 = Trim(ws.Cells(i, 4).Value)

        If Len(grp) > 0 And Len(name) > 0 Then
            
            ' 班ごとのDictionary作成/取得
            If Not dictAll.Exists(grp) Then
                Set dictGrp = CreateObject("Scripting.Dictionary")
                dictGrp.CompareMode = vbTextCompare
                dictAll.Add grp, dictGrp
            Else
                Set dictGrp = dictAll(grp)
            End If

            ' 名前登録（初期値0）
            If Not dictGrp.Exists(name) Then
                dictGrp.Add name, 0
            End If

            ' 資格1カウント
            If Len(qual1) > 0 Then
                dictGrp(name) = dictGrp(name) + 1
            End If
            
            ' 資格2カウント
            If Len(qual2) > 0 Then
                dictGrp(name) = dictGrp(name) + 1
            End If

        End If
    Next i

    ' --- 出力（F:H） ---
    Dim gKey As Variant, nKey As Variant
    Dim r As Long: r = 2

    For Each gKey In dictAll.Keys
        Set dictGrp = dictAll(gKey)
        
        For Each nKey In dictGrp.Keys
            ws.Cells(r, 6).Value = gKey
            ws.Cells(r, 7).Value = nKey
            ws.Cells(r, 8).Value = dictGrp(nKey)
            r = r + 1
        Next nKey
        
    Next gKey

    MsgBox "資格登録数の集計が完了しました！", vbInformation

End Sub

→

配列＋ネストDictionary版

Sub CountQualifications_Array()
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet4")
    
    Dim dictAll As Object, dictGrp As Object
    Set dictAll = CreateObject("Scripting.Dictionary")
    dictAll.CompareMode = vbTextCompare
    
    Dim lastRow As Long
    Dim data As Variant
    
    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
        
        .Range("F:H").ClearContents
        .Range("F1").Value = "班"
        .Range("G1").Value = "名前"
        .Range("H1").Value = "資格数"
        
        If lastRow < 2 Then Exit Sub
        
        ' ▼A2:Dを配列として取得
        data = .Range("A2:D" & lastRow).Value
    End With
    
    Dim i As Long
    Dim grp As String, name As String
    Dim q1 As String, q2 As String
    
    ' ▼集計（1回走査）
    For i = 1 To UBound(data, 1)
        
        grp = Trim(data(i, 1))
        name = Trim(data(i, 2))
        q1 = Trim(data(i, 3))
        q2 = Trim(data(i, 4))
        
        If Len(grp) > 0 And Len(name) > 0 Then
            
            ' 班辞書が無ければ作る
            If Not dictAll.Exists(grp) Then
                Set dictGrp = CreateObject("Scripting.Dictionary")
                dictGrp.CompareMode = vbTextCompare
                dictAll.Add grp, dictGrp
            Else
                Set dictGrp = dictAll(grp)
            End If
            
            ' 名前が無ければ初期値 0
            If Not dictGrp.Exists(name) Then
                dictGrp.Add name, 0
            End If
            
            ' 資格1カウント
            If Len(q1) > 0 Then dictGrp(name) = dictGrp(name) + 1
            
            ' 資格2カウント
            If Len(q2) > 0 Then dictGrp(name) = dictGrp(name) + 1
        End If
    Next i
    
    ' ▼出力用配列へ詰める
    Dim result As Variant
    Dim gKey As Variant, nKey As Variant
    Dim rowCnt As Long: rowCnt = 1
    
    ReDim result(1 To dictAll.Count * 10, 1 To 3) '最大見積
    
    For Each gKey In dictAll.Keys
        Set dictGrp = dictAll(gKey)
        For Each nKey In dictGrp.Keys
            result(rowCnt, 1) = gKey
            result(rowCnt, 2) = nKey
            result(rowCnt, 3) = dictGrp(nKey)
            rowCnt = rowCnt + 1
        Next nKey
    Next gKey
    
    ' ▼実行結果を一括書き戻し
    ws.Range("F2").Resize(rowCnt - 1, 3).Value = result
    
    MsgBox "資格数の集計が完了しました！", vbInformation
    
End Sub

コメント