和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > VBA問題集 > VBA課題009「人事データからクロス表を作成」マクロ2回答コード

VBA課題009「人事データからクロス表を作成」マクロ2回答コード

VBA問題集 Dictionary VBA

Excel・VBA総合コミュニティ「Excel-Fun.xls*」にて定期出題される、
VBAの問題に対する私の回答ソースコードを掲載いたします。


今回掲載するコードは第6回課題共有会の課題でもあった、
「人事データからクロス表を作成」問題です。
VBA課題009「人事データからクロス表を作成」

今回は2つのマクロが出題されているのですが、

  1. マクロ1は出力順にソートしたデータ全行をループしていく手法
  2. マクロ2はクロス表の出力キーごとに職員リストを格納するDictionaryを作成する手法

と、2つの手法で分けて作ってみました。

本記事ではマクロ2の「出力職員リストをDictionaryで作成」パターンを解説します。

課題の内容

今回は人事データをクロス表(マトリクス表)として出力する課題です。
出力元データ
出力帳票

詳細は下記リンク内にある「課題説明」シートをご確認ください。


せっかくなので回答を見る前に皆さんも挑戦してみましょう。

一度自分が作ってから他の人のコードを見ることで、
学習効果が何倍にも高まります。

完成させなくても、出来る範囲で解くだけでも十分効果がありますので、
是非ともトライしてみてください！


◇ 「人事データからクロス表を作成」の課題ファイルはこちら
Discord：★出題【VBA】#009 人事データからクロス表を作成

◇ 「人事データからクロス表を作成」への回答集はこちら
Discord：☆回答【VBA】#009 人事データからクロス表を作成

※上記はDiscord参加済みの方用のURLです
　未参加の方は下記からご参加ください！
www.limecode.jp

課題の回答ファイル

実際の回答ファイルはこちらをご覧ください。
(和風スパ)【VBA】009_人事データからクロス表を作成.xlsm


ソースコード

モジュール全体像

標準モジュール:Df_シートレイアウト

Option Explicit

' データ
Public Const C1stデータ = 1
Public Enum CNoデータ
    職員コード = C1stデータ
    職員名
    職員カナ名
    性別コード
    性別
    役職員区分コード
    役職員区分
    所属区分コード
    所属区分
    所属コード
    所属
    役職コード
    役職名
    入庫日
    追加列_役職グループコード
End Enum
Public Const CLastデータ = CNoデータ.追加列_役職グループコード

' クロス表1
Public Const R1stクロス表1 = 3
Public Const RLastクロス表1 = 500
Public Const RNoクロス表1_合計 = 501
Public Const C1stクロス表1 = 1
Public Enum CNoクロス表1
    役職グループコード = C1stクロス表1
    役職名
    人数 = 12 ' マジックナンバー注意
End Enum
Public Const CLastクロス表1 = CNoクロス表1.人数
Public Const CCountクロス表1 = CLastクロス表1 - C1stクロス表1 + 1
Public Const ColumnAdrsクロス表1_氏名出力列 = "C:K"

' クロス表2
Public Const RNoクロス表2_所属名 = 3
Public Const RNoクロス表2_見出し = 4
Public Const R1stクロス表2 = 5
Public Const C1stクロス表2 = 1
Public Const CStepクロス表2_各所属 = 3
Public Const CAdrs_クロス表2_コピー元 = "D:F"
Public Enum CNoクロス表2
    役職グループコード = C1stクロス表1
    役職名
    人数
    データ1st
End Enum
Public Const RGB_各列計 = 65535
Public Const RGB_総計 = 49407

' マスタ
Public Enum CNoマスタ
    役職コード = 14
    役職名
    役職グループコード
End Enum

' クロス表1各列
Function GetCNoクロス表1(所属コード As Long) As Long
    On Error Resume Next
    GetCNoクロス表1 = Fx.Match(所属コード, TplWSクロス表1.Rows(1))
End Function

' 役職マスタの参照
Function GetRange役職名リスト(指定役職グループコード As Long) As Range
    Dim Tbl役職マスタ As ListObject
    Set Tbl役職マスタ = WSマスタ.ListObjects("役職マスタTB")
    
    ' グループ1のみ例外的に「役員」のみを対象とする
    If 指定役職グループコード = 1 Then
        Set GetRange役職名リスト = WSマスタ.Cells(Tbl役職マスタ.DataBodyRange.Row, CNoマスタ.役職名)
        Exit Function
    End If
    
    ' マスタ全行をループ
    Dim R As Long, R1st As Long, RLast As Long
    For R = Tbl役職マスタ.DataBodyRange.Row To Get最終行(Tbl役職マスタ.Range)
        
        ' 指定グループの出現行と最終行を取得
        If R1st = 0 And WSマスタ.Cells(R, CNoマスタ.役職グループコード) = 指定役職グループコード Then
            R1st = R
        End If
            
        If R1st > 0 And WSマスタ.Cells(R, CNoマスタ.役職グループコード) <> 指定役職グループコード Then
            RLast = R - 1
            Exit For
        End If
    
    Next ' マスタ全行をループ
    If RLast = 0 Then RLast = Get最終行(Tbl役職マスタ.Range)
    
    ' データがあれば範囲を結果として返す
    If R1st > 0 Then
        Set GetRange役職名リスト = WSマスタ.Range(WSマスタ.Cells(R1st, CNoマスタ.役職名), _
                                                  WSマスタ.Cells(RLast, CNoマスタ.役職名))
    End If
                                                  
End Function

標準モジュール:Pr1_マクロ1

Option Explicit

Private Dic出力職員リスト As Dictionary

' マクロ2
Sub 役職x所属x性別のクロス表を出力する()
    
    Call エクセルの自動更新を停止する(False)

    ' ■ 出力枠ごとの職員リストを登録したDictionaryを生成
    Set Dic出力職員リスト = GetDictionary役職Gx所属x性別ごとの職員リスト

    ' ひな形を新規ブックに出力
    TplWSクロス表2.Copy
    Dim ws出力 As Worksheet: Set ws出力 = ActiveSheet
    
    On Error Resume Next
    Dim シート名 As String: シート名 = opWSMENU.Range("D4")
    ws出力.Name = シート名
    On Error GoTo 0
    
    ' すべての所属名を出力し書式をテンプレート列からコピー
    Dim Tbl所属マスタ As ListObject
    Set Tbl所属マスタ = WSマスタ.ListObjects("所属マスタTB")
    
    Dim C_出力 As Long: C_出力 = CNoクロス表2.データ1st
    Dim 所属名
    For Each 所属名 In Tbl所属マスタ.ListColumns(2).DataBodyRange
        C_出力 = C_出力 + CStepクロス表2_各所属
        
        ws出力.Columns(CAdrs_クロス表2_コピー元).Copy ws出力.Cells(1, C_出力)
        ws出力.Cells(RNoクロス表2_所属名, C_出力) = 所属名
    Next
    
    ' 書式テンプレート列を削除
    ws出力.Columns(CAdrs_クロス表2_コピー元).Delete

    ' データ作成用の作業シートを生成
    ws出力.Copy after:=ws出力
    Dim ws作業 As Worksheet: Set ws作業 = ActiveSheet
    ws作業.Name = "作業"
    
    ' 役職グループごとに出力処理
    Dim 役職グループコード As Long
    For 役職グループコード = 1 To 9
    
        If Not GetRange役職名リスト(役職グループコード) Is Nothing Then
    
            ' ■ 出力メインプロシージャ
            Call 指定役職グループコードのクロス表出力部を作業シートに作成する(役職グループコード, ws作業)
            Dim コピー行数 As Long: コピー行数 = Get最終行(ws作業) - R1stクロス表2 + 1
            ws作業.Rows(R1stクロス表2).Resize(コピー行数).Copy ws出力.Cells(Get最終行(ws出力) + 1, 1)
        
        End If
    
    Next
    
    ' 作業シートを消去
    Call シートを削除する(ws作業)
    
    ' 書式設定と計算式欄の計算
    With ws出力
        
        Dim R_小計最終 As Long: R_小計最終 = Get最終行(ws出力)
        Dim R_各列計 As Long: R_各列計 = R_小計最終 + 1
        Dim R_総計 As Long: R_総計 = R_小計最終 + 2
        Dim C_最終 As Long: C_最終 = Get最終列(ws出力)
        
        ' 書式設定
        .Rows(R_小計最終).Copy .Rows(R_各列計)
        .Cells(R_各列計, CNoクロス表2.人数).Resize(, C_最終 - CNoクロス表2.人数 + 1).Interior.Color = RGB_各列計
        .Rows(R_小計最終).Copy .Rows(R_総計)
        .Cells(R_総計, CNoクロス表2.人数).Resize(, C_最終 - CNoクロス表2.人数 + 1).Interior.Color = RGB_総計
        
        ' 各列計の計算
        Dim C As Long
        For C = CNoクロス表2.人数 To Get最終列(ws出力.UsedRange)
            .Cells(R_各列計, C) = Fx.Sum(.Range(.Cells(R1stクロス表2, C), .Cells(R_小計最終, C)))
        Next
        
        ' 総計の計算
        .Cells(R_総計, CNoクロス表2.人数) = .Cells(R_各列計, CNoクロス表2.人数)
        
        For C = CNoクロス表2.データ1st To Get最終列(ws出力.UsedRange) Step CStepクロス表2_各所属
            Application.DisplayAlerts = False
            .Cells(R_総計, C).Resize(1, CStepクロス表2_各所属).Merge
            Application.DisplayAlerts = True
            .Cells(R_総計, C) = Fx.Sum(.Cells(R_各列計, C).Resize(1, CStepクロス表2_各所属))
        Next
        
        ' 各列計が0だったその他列を削除
        For C = Get最終列(ws出力) To CNoクロス表2.データ1st Step -CStepクロス表2_各所属
            
            If .Cells(R_各列計, C) = 0 Then
                .Columns(C).Delete
            End If
        
        Next
        
        ' 最後の所属のその他列が削除された場合の罫線復元
        C_最終 = Get最終列(ws出力)
        .Range(.Cells(RNoクロス表2_所属名, C_最終) _
             , .Cells(R_総計, C_最終)).Borders(xlEdgeRight).Weight = xlThin
        
    End With
    
    ' デバッグ用表示列の値を消去
    ws出力.Columns(CNoクロス表2.役職グループコード).Value = ""
    
    Call エクセルの自動更新を開始する
    MsgBox "クロス表の出力を完了しました。"
    
End Sub

' 各役職グループごとの出力
Sub 指定役職グループコードのクロス表出力部を作業シートに作成する(指定グループコード As Long, ws作業 As Worksheet)
    
    ' 作業シートを初期化
    Call 指定行より下をすべて削除する(ws作業, R1stクロス表2)
    
    ' 役職名を出力
    ws作業.Cells(R1stクロス表2, CNoクロス表2.役職グループコード) = 指定グループコード
    Call 値をコピーする(ws作業.Cells(R1stクロス表2, CNoクロス表2.役職名), GetRange役職名リスト(指定グループコード))

    ' Dictionaryから各列へ対象のItemを出力
    Dim C As Long
    For C = CNoクロス表2.データ1st To Get最終列(ws作業.UsedRange)

        ' 各列のKeyを取得
        Dim key役職Gx所属x性別 As String
        key役職Gx所属x性別 = 指定グループコード & "_" _
            & ws作業.Cells(RNoクロス表2_所属名, C).MergeArea.Cells(1) & "_" _
            & ws作業.Cells(RNoクロス表2_見出し, C)
            
        ' デバッグ用
        ws作業.Cells(1, C) = key役職Gx所属x性別
        
        ' Itemの出力
        If Dic出力職員リスト.Exists(key役職Gx所属x性別) Then
            
            ' 配列化してセルに出力
            Dim Arr出力職員: Arr出力職員 = Split(Dic出力職員リスト(key役職Gx所属x性別), ",")
            Call 一次元配列をセルに出力する(Arr出力職員, ws作業.Cells(R1stクロス表2, C))
            
            ' 派遣社員のみ役職区分を着色
            Dim cell出力 As Range
            For Each cell出力 In ws作業.Cells(R1stクロス表2, C).Resize(Count配列の要素数(Arr出力職員))

                Call 指定セル内の指定文字を着色する(cell出力, "派遣社員", Colorテキスト色.赤)
                
            Next
            
        End If
        
    Next
    
    ' 罫線の作成
    Dim データ数 As Long: データ数 = Get最終行(ws作業) - R1stクロス表2 + 1
    Call セル範囲の外枠に罫線を引く(ws作業.Cells(R1stクロス表2, CNoクロス表2.役職名).Resize(データ数))
    Call セル範囲の外枠に罫線を引く(ws作業.Cells(R1stクロス表2, CNoクロス表2.人数).Resize(データ数))
    
    For C = CNoクロス表2.データ1st To Get最終列(ws作業.UsedRange) Step CStepクロス表2_各所属
        Call セル範囲の外枠に罫線を引く(ws作業.Cells(R1stクロス表2, C).Resize(データ数, CStepクロス表2_各所属))
    Next
    
    ' 小計欄の書式設定
    Dim R_小計 As Long: R_小計 = Get最終行(ws作業) + 1
    ws作業.Rows(RNoクロス表2_見出し).Copy ws作業.Rows(R_小計)
    ws作業.Cells(R_小計, 1) = "": ws作業.Cells(R_小計, 2) = ""
    ws作業.Cells(R_小計, 2).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
    
    ' 小計の計算
    For C = CNoクロス表2.データ1st To Get最終列(ws作業.UsedRange)
        ws作業.Cells(R_小計, C) = Fx.CountA(ws作業.Cells(R1stクロス表2, C).Resize(データ数))
    Next
    
    ' 人数の計算
    ws作業.Cells(R_小計, CNoクロス表2.人数) = Fx.Sum _
            (ws作業.Cells(R_小計, CNoクロス表2.データ1st).Resize(1, Get最終列(ws作業)))

End Sub

' 出力枠ごとの職員リストを登録したDictionary
Function GetDictionary役職Gx所属x性別ごとの職員リスト() As Dictionary

    Dim Dic職員リスト As New Dictionary
    
    ' テーブル範囲の取得
    Dim TabelRangeデータ As Range
    Set TabelRangeデータ = WSデータ.ListObjects(1).Range
    
    ' 役職グループ列の追加
    WSデータ.Columns(CNoデータ.追加列_役職グループコード).Insert CopyOrigin:=xlFormatFromRightOrBelow
    WSデータ.Cells(TabelRangeデータ.Row, CNoデータ.追加列_役職グループコード) = "役職グループコード"
    Dim 役職グループコードデータエリア As Range
    Set 役職グループコードデータエリア = WSデータ.ListObjects(1).ListColumns(CNoデータ.追加列_役職グループコード).DataBodyRange
    役職グループコードデータエリア.Formula = "=VALUE(LEFT([@役職コード],1))"
    Set TabelRangeデータ = WSデータ.ListObjects(1).Range

    ' クロス表出力既定順にソート
    With WSデータ
        .Sort.SortFields.Clear
        .Sort.SortFields.Add .Cells(1, CNoデータ.役職コード)
        .Sort.SortFields.Add .Cells(1, CNoデータ.所属コード)
        .Sort.SortFields.Add .Cells(1, CNoデータ.職員コード)
        .Sort.SetRange TabelRangeデータ
        .Sort.Header = xlYes
        .Sort.Apply
    End With
    
    ' データ全行をループ
    Dim R As Long
    For R = TabelRangeデータ.Row + 1 To Get最終行(TabelRangeデータ)

        ' Keyの生成
        Dim key役職Gx所属x性別 As String
        key役職Gx所属x性別 = WSデータ.Cells(R, CNoデータ.追加列_役職グループコード) & "_" _
                           & WSデータ.Cells(R, CNoデータ.所属) & "_" _
                           & WSデータ.Cells(R, CNoデータ.性別)
        ' Itemの生成
        Dim item職員名 As String
        item職員名 = WSデータ.Cells(R, CNoデータ.職員名)
        Select Case WSデータ.Cells(R, CNoデータ.役職員区分)
        Case "役員"
            item職員名 = item職員名 & "　" & WSデータ.Cells(R, CNoデータ.役職名)
        
        Case "パート", "嘱託", "派遣社員"
            item職員名 = item職員名 & "　" & WSデータ.Cells(R, CNoデータ.役職員区分)
        End Select
        
        ' Dictionaryへの登録
        If Dic職員リスト.Exists(key役職Gx所属x性別) = False Then
            Dic職員リスト.Add key役職Gx所属x性別, item職員名
        Else
            Dic職員リスト(key役職Gx所属x性別) = Dic職員リスト(key役職Gx所属x性別) & "," & item職員名
        End If

    Next  'データ全行をループ
    
    Set GetDictionary役職Gx所属x性別ごとの職員リスト = Dic職員リスト

End Function

標準モジュール:Ut_汎用関数

Option Explicit

Public Enum Colorテキスト色
    白 = 16777215
    黒 = 0
    灰 = 8421504
    赤 = 255
    橙 = 3243501
    黄 = 49407
    緑 = 5287936
    青 = 12611584
    紫 = 10498160
End Enum

Function Get最終行(指定オブジェクト As Object) As Long
    Dim セル範囲 As Range
    
    Select Case TypeName(指定オブジェクト)
    Case "Range": Set セル範囲 = 指定オブジェクト
    Case "Worksheet": Set セル範囲 = 指定オブジェクト.UsedRange
    Case "ListObject": Set セル範囲 = 指定オブジェクト.Range
    End Select
    
    Get最終行 = セル範囲.Rows.Count + セル範囲.Row - 1
End Function
Function Get最終列(指定オブジェクト As Object) As Long
    Dim セル範囲 As Range
    
    Select Case TypeName(指定オブジェクト)
    Case "Range": Set セル範囲 = 指定オブジェクト
    Case "Worksheet": Set セル範囲 = 指定オブジェクト.UsedRange
    Case "ListObject": Set セル範囲 = 指定オブジェクト.Range
    End Select
    
    Get最終列 = セル範囲.Columns.Count + セル範囲.Column - 1
End Function

Function Is上のセルと同値(セル As Range) As Boolean
    Is上のセルと同値 = (セル.Value = セル.Offset(-1).Value)
End Function

Sub 値をコピーする(cell貼付先 As Range, rngコピー元 As Range)
    cell貼付先.Resize(rngコピー元.Rows.Count, rngコピー元.Columns.Count).Value = rngコピー元.Value
End Sub

Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

Sub セルを選択してs秒待機する(セル As Range, s As Double)
    セル.Worksheet.Activate
    セル.Select
    Application.Wait [Now()] + s / 86400
End Sub

Sub 一次元配列をセルに出力する(Arr出力, cell出力始点 As Range)

    Dim 出力セル範囲 As Range
    Set 出力セル範囲 = cell出力始点.Resize(UBound(Arr出力) - LBound(Arr出力) + 1, 1)

    出力セル範囲.Value = Fx.Transpose(Arr出力)

End Sub

Sub セル範囲の外枠に罫線を引く(セル範囲 As Range)

    Dim 各Edge
    For Each 各Edge In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)

        With セル範囲.Borders(各Edge)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        
    Next
    
End Sub

Sub 指定行より下をすべて削除する(指定シート As Worksheet, 指定行 As Long)

    With 指定シート

        指定シート.Rows(指定行).Resize(.UsedRange.Rows.Count).Delete
    
    End With

End Sub

Sub シートを削除する(削除シート As Worksheet)
    Application.DisplayAlerts = False
    削除シート.Delete
    Application.DisplayAlerts = True
End Sub


Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

Function 指定セルの右からn文字を着色する(cell As Range, n As Long, RGB値 As Long)
    
    Dim セル文字数 As Long
    セル文字数 = cell.Characters.Count
    
    cell.Characters(セル文字数 - n + 1, n).Font.Color = RGB値
    
End Function

Function 指定セル内の指定文字を着色する(cell As Range, 着色文字 As String, RGB値 As Long)
    
    Dim instr発見位置 As Long
    instr発見位置 = InStr(cell.Value, 着色文字)
    
    If instr発見位置 > 0 Then
        cell.Characters(instr発見位置, Len(着色文字)).Font.Color = RGB値
    End If
    
End Function

Sub エクセルの自動更新を停止する(ブック計算をOFF As Boolean _
    , Optional 画面更新をOFF As Boolean = True, Optional イベントをOFF As Boolean = True _
    , Optional カーソルをOFF As Boolean = True)
    With Application
        If ブック計算をOFF Then .Calculation = xlCalculationManual
        If 画面更新をOFF Then .ScreenUpdating = False
        If イベントをOFF Then .EnableEvents = False
        If カーソルをOFF Then .Cursor = xlWait
    End With
End Sub

Function エクセルの自動更新を開始する()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
        .DisplayAlerts = True
        .Cursor = xlDefault
    End With
    ' 合わせて検索オプションを部分一致に設定
    Call Cells.Find("", lookat:=xlPart)
End Function

コードの解説

マクロ2ではDictionaryを使って搭載しました。

まずは全データをループして以下のような
「役職x所属x性別」を渡すと対象の職員リストをくれるDictionaryを作ります。

?Dic職員リスト("6_総務部_男性") ' ← 「児玉 泰宏,境 崇,荒井 裕晃」を返す

　
KeyとItemがともに区切り文字を使ったただの文字列(String)で、

  • Key：役職グループ & "_" & 所属 & "_" & 性別
  • Item：職員名1 & "," & 職員名2 & …

このような構造のDicitonaryとなっています。


このDictionaryを作ること自体は難しくなく、
全データに対して以下のコードを実行してDictionaryにデータを格納しています。

' Keyの生成
Dim key役職Gx所属x性別 As String
key役職Gx所属x性別 = WSデータ.Cells(R, CNoデータ.追加列_役職グループコード) & "_" _
                   & WSデータ.Cells(R, CNoデータ.所属) & "_" _
                   & WSデータ.Cells(R, CNoデータ.性別)
' Itemの生成
Dim item職員名 As String
item職員名 = WSデータ.Cells(R, CNoデータ.職員名)

' Dictionaryへの登録
If Dic職員リスト.Exists(key役職Gx所属x性別) = False Then
    Dic職員リスト.Add key役職Gx所属x性別, item職員名
Else
    Dic職員リスト(key役職Gx所属x性別) = Dic職員リスト(key役職Gx所属x性別) & "," & item職員名
End If

　
データそれぞれで必要な値を&で結合して格納しているだけですね。

これさえ作ってしまえば、あとはすべての役職・所属・性別をループし、
該当するKeyに格納された職員リストを出力していけばクロス表が完成します。


クロス表に出力する際は、クロス表の行から役職、列から所属と性別を取得し、
格納時と同じように「役職 & "_" & 所属 & "_" & 性別」の文字列を作ります。

' 各列のKeyを取得
Dim key役職Gx所属x性別 As String
key役職Gx所属x性別 = 指定グループコード & "_" _
    & ws作業.Cells(RNoクロス表2_所属名, C).MergeArea.Cells(1) & "_" _
    & ws作業.Cells(RNoクロス表2_見出し, C)

　
このKeyをDictionaryに渡せば「カンマ区切りの職員リスト」がもらえますので、
あとはそれをSplitして配列にし、セルに出力するだけということですね。


今回のクロス表のような複雑なループ制御を必要とする処理では、

  1. まずはDictionaryなどを用いてデータを構造化する
  2. 構造化したデータを順次出力していくよ

という工程を経ることで、コードをかなり簡潔に整理することができます。

今回は製作時間も図っていたのですが、マクロ2の方複雑であるにもかかわらず、
マクロ2の方がマクロ1よりも作成時間も短くなりました。


Dictionaryを使ってデータを整理できるようになると、
データの抽出とデータの出力を分けて行うことができるようになります。

今回の課題はその練習にピッタリですので、
この機会にDictionaryの使い方を勉強してみて下さい。