複数のシートからデータを集約して一覧表に転記

昨日のフローチャート作成を中締めとして、文体を「です・ます」調から「だ・である」調に変えてみる。理由は、その方が書き易いから。しっくりこない場合は、また元に戻すこととする。

本日のテーマ

さて昨晩、困りごととして下記の事案を拝見した。

要件：複数のシートから情報（一週間のシフト情報）を集約し、一覧表化したい。
・各データシート（①はシフト１、②はシフト２、③はシフト３の意）

・集約結果（「割り振り表」シート）

そこで、マクロによる自動集計に挑戦してみた。

考え方と手順

1. 番号と名前から辞書（連想配列）を作成
2. 番号をインデックスとする配列（クラスモジュール）を作成
3. データの入力範囲をループして、情報を収集
4. 一覧表にデータ貼り付け

なお、見当など全く付いていないが、もっと良い方法があることは間違いないという確信がある。でも、今はこれが精一杯。

１．番号と名前から辞書（連想配列）を作成

佐藤さんの月曜日のシフトは？というデータを取りたい場合、引数が「佐藤さん」のままでは少々扱いにくい。そのためには、佐藤さんに紐づく唯一無二のコードがあって、これが数字であれば都合がよい。
確認したところ、「割り振り表」シートにある番号が、これに相当するとのこと。また、同姓同名の方がいたとしても「佐藤①」「佐藤②」のような区別が為されるため、名前もまたユニーク（唯一無二）であることが分かった。

そこでまず、名前と番号で辞書（連想配列）を作成することにした。

【標準モジュール】※Scripting Runtime を参照設定済み。

Function GetRosterDict() As Dictionary

    Dim Sh As Worksheet
    Set Sh = Sheets("割り振り表")
    
    Dim myRng As Range
    Set myRng = Range(Sh.Cells(3, "A"), Sh.Cells(Rows.Count, "B").End(xlUp))
    
    Dim TempDict As Dictionary
    Set TempDict = New Dictionary
    Dim i As Long
        With myRng
            For i = 1 To myRng.Rows.Count
                TempDict(.Cells(i, "B").Value) = .Cells(i, "A").Value
            Next
        End With
    
    Set GetRosterDict = TempDict

End Function

２．番号をインデックスとする配列（クラスモジュール）を作成

「番号」の最大値でもって、配列をRedimする。これで、各番号をインデックスとする配列が、各自のデータを格納することになる。
例えば佐藤さんは100番なので、このような過程を経る。

1. 佐藤さんは・・・100番か。
2. Person(100) 持ってきて！
3. 月曜日はシフト１か。
4. Person(100). 月 = シフト1 です。

【標準モジュール】

Option Explicit
Public Person() As ShiftData
Public Enum 曜日列
    月 = 3　' 実際の「割り振り表シート」のレイアウトに合わせて変更
    火
    水
    木
    金
    土
    日
End Enum
Public Sh(2) As Worksheet

全データ集約のためのサブプロシージャ。

Sub GetAllShiftData()
        
    Dim MaxNumber As Long
        MaxNumber = WorksheetFunction.Max(GetRosterDict.Items)

    ReDim Person(MaxNumber)
    
    Dim Item As Variant
        For Each Item In GetRosterDict.Items
            Set Person(Item) = New ShiftData
        Next
    
    ' 今回は、シート３とシート５の二つにデータがある例で作成。
    Set Sh(0) = Sheets("割り振り表")
    Set Sh(1) = Sheets("シート３")
    Set Sh(2) = Sheets("シート５")
    
    Dim i As Long
        For i = 1 To UBound(Sh)
            Call GetShiftData(Sh(i))
        Next
    
End Sub

話が前後するが、クラスモジュールを一つ準備する。今回、名前は「ShiftData」とする。

【クラスモジュール】（ShiftData）

Option Explicit

Public 名前 As String
Public 番号 As Long
Public 月 As String
Public 火 As String
Public 水 As String
Public 木 As String
Public 金 As String
Public 土 As String
Public 日 As String

「名前」と「番号」は使わないかもしれないが、一応情報として格納できるようにしておく。
なお、これらの手法は、今回も ↓ を参考にした（いつも有難うございます）。
thom.hateblo.jp

３．データの入力範囲をループして、情報を収集

GetAllShiftDataからの指示を受け、各シート名を引数として情報を集約するプロシージャを作成する。

Sub GetShiftData(Sh As Worksheet)
    
    Dim myRng As Range
    Set myRng = Range(Sh.Range("C2"), Sh.Range("H29"))
    
    Dim r As Range
    Dim myIndex As Long
    Dim myShift As String
    Dim myWeekDayNumber As Long
        For Each r In myRng
            If r <> "" Then
                myIndex = GetRosterDict(r.Value)
                myShift = "シフト" & StrConv(WorksheetFunction.RoundDown(r.Column / 2, 0), vbWide)
                myWeekDayNumber = WorksheetFunction.RoundUp((r.Row - 1) / 4, 0)
                With Person(myIndex)
                    Select Case myWeekDayNumber
                        Case 1: .月 = myShift
                        Case 2: .火 = myShift
                        Case 3: .水 = myShift
                        Case 4: .木 = myShift
                        Case 5: .金 = myShift
                        Case 6: .土 = myShift
                        Case 7: .日 = myShift
                    End Select
                    .名前 = r.Value
                    .番号 = myIndex
                End With
            End If
        Next

End Sub

データの範囲は、実際に即して適宜変更となる。
また、例えば今回作成したサンプルでは

• ３，４行目・・・シフト１
• ５，６行目・・・シフト２
• ７，８行目・・・シフト３

となっていたため、名前が入力されているセルの列数を２で割って小数点以下を切り捨てることで、シフト番号に変換している。ちょっと強引。
同様に曜日についても、４行おきに月 ⇒ 火 ⇒ 水 ・・・となっているため、４で割って小数点以下を切り上げることで、月 ～ 日 を １～７とした。これも強引。

４．一覧表にデータ貼り付け

最後に、割り振り表にデータを張り付ける。

Sub PostingToShiftTable()
    Call GetAllShiftData
    Dim i As Long
        For i = 3 To 14
            With Person(Sh(0).Cells(i, 1).Value)
                Sh(0).Cells(i, 曜日列.月) = .月
                Sh(0).Cells(i, 曜日列.火) = .火
                Sh(0).Cells(i, 曜日列.水) = .水
                Sh(0).Cells(i, 曜日列.木) = .木
                Sh(0).Cells(i, 曜日列.金) = .金
                Sh(0).Cells(i, 曜日列.土) = .土
                Sh(0).Cells(i, 曜日列.日) = .日
            End With
        Next
End Sub

月曜日の列に、月曜日のデータを張り付ける。という風に、直感的な分かり易さを重視してみた。しかしその分だけ、如何せん、コードが長くなってしまった。この辺り、改良の余地があると思われ。

結果

複数のシートに分かれた、シフトに関する情報を集約できた。

参考まで。