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

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

本日のテーマ

さて昨晩、困りごととして下記の事案を拝見した。
f:id:Infoment:20181004205858p:plain
要件:複数のシートから情報(一週間のシフト情報)を集約し、一覧表化したい。
・各データシート(①はシフト1、②はシフト2、③はシフト3の意)
f:id:Infoment:20181004194257p:plain

・集約結果(「割り振り表」シート)
f:id:Infoment:20181004194336p:plain

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

考え方と手順

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

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

1.番号と名前から辞書(連想配列)を作成

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

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

【標準モジュール】※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

2.番号をインデックスとする配列(クラスモジュール)を作成

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

  1. 佐藤さんは・・・100番か。
  2. Person(100) 持ってきて!
  3. 月曜日はシフト1か。
  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
    
    ' 今回は、シート3とシート5の二つにデータがある例で作成。
    Set Sh(0) = Sheets("割り振り表")
    Set Sh(1) = Sheets("シート3")
    Set Sh(2) = Sheets("シート5")
    
    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
PublicAs String
PublicAs String
PublicAs String
PublicAs String
PublicAs String
PublicAs String
PublicAs String

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

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

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

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

  • 3,4行目・・・シフト1
  • 5,6行目・・・シフト2
  • 7,8行目・・・シフト3

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

4.一覧表にデータ貼り付け

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

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

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

結果

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

f:id:Infoment:20181004215424g:plain

参考まで。