VBA Dictionary 一覧から一覧

Sub CreateEmployeeLicenseMatrix()

    Dim wsData As Worksheet
    Dim wsLic As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Sheet6")        '元データ
    Set wsLic = ThisWorkbook.Worksheets("資格名一覧")      '資格マスタ
    
    Dim dictEmp As Object, dictLic As Object
    Set dictEmp = CreateObject("Scripting.Dictionary")
    dictEmp.CompareMode = vbTextCompare
    
    Dim lastRow As Long, maxLic As Long
    Dim dataArray As Variant, licListArray As Variant
    Dim i As Long
    
    ' ================================
    ' ■資格マスタ取得
    ' ================================
    With wsLic
        maxLic = .Cells(.Rows.Count, "A").End(xlUp).row
        licListArray = .Range("A1:A" & maxLic).Value  '縦方向配列(1始まり)
    End With
    
    ' ================================
    ' ■元データ取得
    ' ================================
    With wsData
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
        
        ' F以降クリア
        .Range("F:Z").ClearContents
        
        If lastRow < 2 Then Exit Sub
        
        dataArray = .Range("A2:D" & lastRow).Value
    End With
    
    Dim empNo As String, empName As String, empDept As String, lic As String
    
    ' ================================
    ' ■社員情報 × 資格Dictionary作成
    ' ================================
    For i = 1 To UBound(dataArray, 1)
        
        empNo = Trim(dataArray(i, 1))  '文字列3桁社員番号
        empName = Trim(dataArray(i, 2))
        empDept = Trim(dataArray(i, 3))
        lic = Trim(dataArray(i, 4))
        
        If Len(empNo) > 0 Then
            
            ' 新規社員登録
            If Not dictEmp.Exists(empNo) Then
                Set dictLic = CreateObject("Scripting.Dictionary")
                dictLic.CompareMode = vbTextCompare
                dictEmp.Add empNo, Array(empName, empDept, dictLic)
            End If
            
            Set dictLic = dictEmp(empNo)(2)
            
            ' 資格重複排除
            If Len(lic) > 0 Then
                If Not dictLic.Exists(lic) Then
                    dictLic.Add lic, True
                End If
            End If
            
        End If
    Next i

    ' ================================
    ' ■社員番号ソート（文字列昇順）
    ' ================================
    Dim arrKeys As Variant
    arrKeys = dictEmp.keys
    arrKeys = SortStringArray(arrKeys) '※後述

    ' ================================
    ' ■結果出力用配列作成
    ' ================================
    Dim result() As Variant
    Dim r As Long: r = 1
    Dim c As Long, e As Variant
    
    ReDim result(1 To dictEmp.Count, 1 To maxLic + 3)
    
    For Each e In arrKeys
        
        result(r, 1) = e
        result(r, 2) = dictEmp(e)(0)
        result(r, 3) = dictEmp(e)(1)
        
        Set dictLic = dictEmp(e)(2)
        
        For c = 1 To maxLic
            If dictLic.Exists(licListArray(c, 1)) Then
                result(r, c + 3) = "○"
            End If
        Next c
        
        r = r + 1
    Next e
    
    ' ================================
    ' ■シート出力（見出し付き）
    ' ================================
    Dim ws As Worksheet
    Set ws = wsData '直接出力する位置
    
    ws.Range("F1").Value = "社員番号"
    ws.Range("G1").Value = "名前"
    ws.Range("H1").Value = "部署"
    
    For c = 1 To maxLic
        ws.Cells(1, 8 + c).Value = licListArray(c, 1) 'I列?
    Next c
    
    ws.Range("F2").Resize(dictEmp.Count, maxLic + 3).Value = result

    MsgBox "資格マトリクス表が完成しました！", vbInformation

End Sub

'---▼文字列配列昇順ソート関数▼---
Private Function SortStringArray(arr As Variant) As Variant
    Dim i As Long, j As Long
    Dim tmp As String
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                tmp = arr(i): arr(i) = arr(j): arr(j) = tmp
            End If
        Next j
    Next i
    SortStringArray = arr
End Function

コメント