和風スパゲティのレシピ

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

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

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

VBA問題集 分岐・ループ構文 VBA

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


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

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

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

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

本記事ではマクロ1の「データを出力順ソート→全行ループ」パターンを解説します。

課題の内容

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

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


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

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

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


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

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

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

課題の回答ファイル

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


ソースコード

モジュール全体像

※ Df_シートレイアウト、Ut_汎用関数の2モジュールには、
マクロ2で使う定数・関数も搭載されております。
本記事のコードには不要なコードですので適宜読み飛ばしてください。

標準モジュール: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 Const isデバッグモード = False

' マクロ1
Sub 役職x所属のクロス表を出力する()

    ' ひな形を新規ブックに出力
    TplWSクロス表1.Copy
    Dim ws出力 As Worksheet: Set ws出力 = ActiveSheet
    On Error Resume Next
    Dim シート名 As String: シート名 = opWSMENU.Range("B4")
    ws出力.Name = シート名
    On Error GoTo 0

    ' テーブル範囲の取得
    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.SortFields.Add .Cells(1, CNoデータ.職員コード)
        .Sort.SetRange TabelRangeデータ
        .Sort.Header = xlYes
        .Sort.Apply
    End With
    
    ' データ全行を支店登場までループ
    Dim R_出力 As Long
    Dim R_役職グループごとの第1出力行 As Long: R_役職グループごとの第1出力行 = R1stクロス表1
    Dim Count_所属ごとの出力人数 As Long
    Dim Max_役職ごとの最大出力人数 As Long: Max_役職ごとの最大出力人数 = 0
    Dim R_データ As Long
    For R_データ = TabelRangeデータ.Row + 1 To Get最終行(TabelRangeデータ)
        If WSデータ.Cells(R_データ, CNoデータ.所属区分コード) <> 1 Then Exit For
        
        ' 役職グループコード変更時に出力行を更新
        If Not Is上のセルと同値(WSデータ.Cells(R_データ, CNoデータ.追加列_役職グループコード)) Then
            
            If R_データ <> TabelRangeデータ.Row + 1 Then
                Dim 人数セル As Range
                Set 人数セル = ws出力.Range(ws出力.Cells(R_役職グループごとの第1出力行, CNoクロス表1.人数) _
                                          , ws出力.Cells(R_役職グループごとの第1出力行 + Max_役職ごとの最大出力人数 - 1, CNoクロス表1.人数))
                人数セル.Merge
                人数セル.Value = Fx.CountA(Intersect(人数セル.EntireRow, ws出力.Columns(ColumnAdrsクロス表1_氏名出力列)))
            End If
            
            ' 各カウンタの更新
            R_役職グループごとの第1出力行 = R_役職グループごとの第1出力行 + Max_役職ごとの最大出力人数
            Max_役職ごとの最大出力人数 = 1
            R_出力 = R_役職グループごとの第1出力行
            Count_所属ごとの出力人数 = 0
            
            ws出力.Cells(R_出力, C1stクロス表1).Resize(1, CCountクロス表1).Borders(xlEdgeTop).Weight = xlThin
            
            ' 役職名と役職グループコードを印字
            ws出力.Cells(R_出力, CNoクロス表1.役職グループコード) _
                = WSデータ.Cells(R_データ, CNoデータ.追加列_役職グループコード)
            
            Dim rng役職リスト As Range
            Set rng役職リスト = GetRange役職名リスト(ws出力.Cells(R_出力, CNoクロス表1.役職グループコード))
            Call 値をコピーする(ws出力.Cells(R_出力, CNoクロス表1.役職名), rng役職リスト)
            
            Max_役職ごとの最大出力人数 = rng役職リスト.Rows.Count
            
        End If
        
        ' 所属コードが変わるごとに出力行を役職ごとの第1出力行に戻す
        If Not Is上のセルと同値(WSデータ.Cells(R_データ, CNoデータ.所属コード)) Then
            R_出力 = R_役職グループごとの第1出力行
            If Count_所属ごとの出力人数 > Max_役職ごとの最大出力人数 Then
                Max_役職ごとの最大出力人数 = Count_所属ごとの出力人数
            End If
            Count_所属ごとの出力人数 = 0
        End If
        
        ' 各氏名の出力
        Dim C_出力 As Long
        C_出力 = GetCNoクロス表1(WSデータ.Cells(R_データ, CNoデータ.所属コード))
        
        If C_出力 > 0 Then
            
            ws出力.Cells(R_出力, C_出力) = WSデータ.Cells(R_データ, CNoデータ.職員名)
            If isデバッグモード Then Call セルを選択してs秒待機する(ws出力.Cells(R_出力, C_出力), 0.1)
            
            R_出力 = R_出力 + 1
            Count_所属ごとの出力人数 = Count_所属ごとの出力人数 + 1
        End If
        
    Next
    
    ' 最後の役職グループコードの人数列を作成
    Set 人数セル = ws出力.Range(ws出力.Cells(R_役職グループごとの第1出力行, CNoクロス表1.人数) _
                              , ws出力.Cells(R_役職グループごとの第1出力行 + Max_役職ごとの最大出力人数 - 1, CNoクロス表1.人数))
    人数セル.Merge
    人数セル.Value = Fx.CountA(Intersect(人数セル.EntireRow, ws出力.Columns(ColumnAdrsクロス表1_氏名出力列)))

    ' 使用しなかった余白行を削除
    Dim R1st削除開始行 As Long
    R1st削除開始行 = R_役職グループごとの第1出力行 + Max_役職ごとの最大出力人数
    ws出力.Range(ws出力.Cells(R1st削除開始行, 1), ws出力.Cells(RLastクロス表1, 1)).EntireRow.Delete
    
    ' 役職グループコード列を削除
    WSデータ.Columns(CNoデータ.追加列_役職グループコード).Delete

    MsgBox "クロス表の出力を完了しました。"

End Sub

標準モジュール: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

コードの解説

今回のコードは上記で説明した通り、

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

この1つ目のコードとなります。


まずはデータを

  1. 役職グループ
  2. 所属名
  3. 職員コード

の順に並び換えを行い、
並び換えたデータを以下の通り出力していく処理で実装しました。
クロス表出力マクロ1

まずは「役職」のブロックごとに処理を行い、
「所属」ごとに縦方向に「職員」を出力していくのがわかります。


このロジックを組む上で重要なのが「行数のカウント」であり、

  • 各所属の出力が終わり次第、役職ごとのスタート位置に戻る
  • 役職内の全所属の出力が終わったら、最も行数が多かった所属+1行目から次の役職を始める

といった処理を各カウンタを制御しながら書いていく必要があります。
　
以下のカウンタでこのロジックを制御していますので、
ロジックを負いたい方はこれらの変数に着目してください。

  • R_役職グループごとの第1出力行
  • Count_所属ごとの出力人数
  • Max_役職ごとの最大出力人数

　

また、今回は「汎用関数の作成」も一つのテーマとして作成しました。

次の役職グループに移るタイミングは
「ひとつ前のデータと役職グループが変わっているか」
で判定をしているのですが、この判定を、

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

という汎用関数を作って、

If Not Is上のセルと同値(WSデータ.Cells(R_データ, CNoデータ.追加列_役職グループコード)) Then

と書くことでコードを簡潔にまとめています。


このような判定関数も汎用関数化すると便利で読みやすくなりますので、
汎用関数を作成するときは意識してみてください。


さて、今回のコードは、

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

この2通りで作成していました。


一見、1のやり方は王道のForループしか使用しないため、
簡単なように感じます。

しかし実際のソースコードをみてわかるように、
作ってみるとなかなか複雑なループになってしまい、
カウンタの更新や初期化にも細心の注意を払う必要があります。


これがプログラムの難しいところで、
「簡単に使えるものだけを使う＝作るのが簡単」という訳ではないのです。


対してマクロ2ではDictionaryを使って搭載しましたので、
習得難易度としてはマクロ2の方が難しい処理を使っています。

処理の概要としては、

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

このように「役職x所属x性別」を渡すとそのリストをくれるDictionaryをまず作り、
それを順番にクロス表に出力していく処理を書きました。


処理自体は難しく感じるかもしれませんが、実際に完成したマクロを見てみると、
マクロ1より簡潔で読みやすくなっていることが分かると思います。

今回はコーディングタイムも図っていたのですが、
マクロ2の方がマクロ1よりも作成時間も短くなりました。
（マクロ2の方が仕様が複雑であるにもかかわらず）


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

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

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


今回の課題はそれを実感するいい題材になると思いますので、
是非マクロ2のコードも見てみてください。

Dictionaryの学習題材としていただけると幸いです。

※ 準備中