Excel-VBAで１週間分の勤怠データをまとめて表示する。

■やりたいこと

　
・１週間分の勤怠データをまとめて表示する
　１シート事に１日の工数データが記載された全シートのデータを１週間分にまとめて、”Summary”シートに出力する。
　実装は１項目のデータに対してクラス設計を用い、後で例として分かりやすくしておく。
　（教育用の適当なサンプルとして後で使えるようにしたいため）

・例：１日の工数データ

・例：１週間分の勤怠データをまとめて表示

##■作った動機：12/20追記
新しい職場に着任して最初に気が付いた事は、工数管理に時間がかかっている事だった。
工数は手作業で2重管するという、劣悪な環境となっていたのだった。(*´Д｀)
またこれによりミスが発生しやすく工数の修正に、工数を消費していた。
そのため業務が忙しい時には、工数管理が重なりさらに忙しくなる悪循環に陥っていた。
そんな状況下で、ある日突然３重となる工数管理が追加された。もはや誰の目にも無理だということは
明らかであった。

##■工数
設計5H
実装3H

■環境：

Environment:
Microsoft Excwl 2019

■実装（module.vbs）

①１項目のデータに対してクラス設計
　１項目のデータに以下のメンバー変数（Property）を設定する
　名前
　項目
　コスト
　日付

csItemcost.vbs

Option Explicit

' メンバ変数(非公開)
Private pvSt_Name As String
Private pvSt_Item As String
Private pvLng_Cost As String
Private pvd_dd As Date
Public csData As csItemcost

' メソッド(公開)
Public Property Let Name(ByVal value As String)
    pvSt_Name = value
End Property
 
Public Property Get Name() As String
 
    Name = pvSt_Name
    
End Property

Public Property Let Item(ByVal value As String)
 
    pvSt_Item = value
 
End Property
 
Public Property Get Item() As String
 
    Item = pvSt_Item
    
End Property

Public Property Let Cost(ByVal value As String)
 
    pvLng_Cost = value
 
End Property
 
Public Property Get Cost() As String
 
    Cost = pvLng_Cost
    
End Property

Public Property Let Dd(ByVal value As Date)
 
    pvd_dd = value
 
End Property
 
Public Property Get Dd() As Date
 
    Dd = pvd_dd
    
End Property

２．勤怠データ作成して、「Summary」シートにデータ出力するまでのを作成する。

module.vbs

Option Explicit
'公開変数
Public lng_endsellrow As Long     '最終行情報
Public myDic As Object            '勤怠データ(Dictionary型)
Public myDicOut As Object         'ソート後の勤怠データ(Dictionary型)

Sub Restore()
    Dim lng_i, lng_j As Long
    Dim tid As Long
    Dim p As csItemcost
    Dim ws As Worksheet
    Dim td As Date
    Dim st_nameexist As String
    
    '初期化
    Set myDic = CreateObject("Scripting.Dictionary")
    Set myDicOut = CreateObject("Scripting.Dictionary")
    tid = 1

    '----------------------------------------------------------------------------------------------
    ''勤怠データ作成
    '----------------------------------------------------------------------------------------------
    For Each ws In ThisWorkbook.Worksheets
        
        If ws.Name = "Summary" Then
            Exit For
        End If
        
        st_nameexist = ""
        td = ws.Cells(1, 3)
        If IsDate(ws.Cells(1, 3)) Then
            '最終行の取得
            lng_endsellrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
            For lng_i = 2 To 6
                If lng_endsellrow < ws.Cells(Rows.Count, lng_i).End(xlUp).Row Then
                   lng_endsellrow = ws.Cells(Rows.Count, lng_i).End(xlUp).Row
                End If
            Next lng_i
            
            'データ取得
            For lng_j = 6 To lng_endsellrow
                
                If ws.Cells(lng_j, 2) <> "" And st_nameexist = "" Then
                    'フルデータ
                    st_nameexist = ws.Cells(lng_j, 2) '
                    
                    Set p = New csItemcost
                    p.Name = st_nameexist
                    p.Item = CStr(ws.Cells(lng_j, 3))
                    p.Cost = CStr(ws.Cells(lng_j, 4))
                    p.Dd = td
                    myDic.Add CStr(tid), p  'Noをキーにクラスを読み込み
                    Set p = Nothing
                    
                    tid = tid + 1
                ElseIf ws.Cells(lng_j, 2) = "" And ws.Cells(lng_j, 3) <> "" And ws.Cells(lng_j, 4) <> "" Then
                    Set p = New csItemcost
                    p.Name = st_nameexist
                    p.Item = CStr(ws.Cells(lng_j, 3))
                    p.Cost = CStr(ws.Cells(lng_j, 4))
                    p.Dd = td
                    myDic.Add CStr(tid), p  'Noをキーにクラスを読み込み
                    Set p = Nothing
                    
                    tid = tid + 1
                ElseIf ws.Cells(lng_j, 2) = "" And ws.Cells(lng_j, 3) = "" And ws.Cells(lng_j, 4) = "" Then
                   '初期化キャンセル
                   st_nameexist = "" '
                End If
              
            Next lng_j
        End If
    Next ws
    
    '----------------------------------------------------------------------------------------------
    ''データの入れ替え（名前でソート）
    '----------------------------------------------------------------------------------------------
    Dim olddd As Date
    Dim oldName As String
    Dim lng_ii As Long

    '初期化
    olddd = myDic(CStr(1)).Dd   '日付の初期化
    oldName = myDic(CStr(1)).Name
    lng_ii = 1                 '設定行の初期化

    For lng_i = 1 To tid - 1 '最終データまで
        'データの表示
        If oldName = myDic(CStr(lng_i)).Name Then
            If myDicOut.Exists(CStr(lng_ii)) = False Then  'データが存在していない
                Call SubSetcsItemcost1(lng_i, lng_ii)
               '行
               lng_ii = lng_ii + 1
            End If
        Else
            For lng_j = lng_i To tid - 1 '最終データまで
                If oldName = myDic(CStr(lng_j)).Name And myDicOut.Exists(CStr(lng_ii)) = False Then '同じ名前でデータが存在していない
                    Call SubSetcsItemcost1(lng_j, lng_ii)
                    '行
                    lng_ii = lng_ii + 1
                End If
            Next lng_j
            If myDicOut.Exists(CStr(lng_ii)) = False Then  'データが存在していない
                Call SubSetcsItemcost1(lng_i, lng_ii)
                Set p = Nothing
                '行
                lng_ii = lng_ii + 1
            End If
        End If

        '前回値
        olddd = myDic(CStr(lng_i)).Dd      '日付
        oldName = myDic(CStr(lng_i)).Name  'Name
    Next lng_i
    
    '----------------------------------------------------------------------------------------------
    ''「Summary」シート作成
    '----------------------------------------------------------------------------------------------
    ' 新しいシートを作成して、名前を「Summary」にする
    Dim summarySheet As Worksheet
    Dim sheetName As String
    Dim sheetExists As Boolean
    
    sheetName = "Summary"
    sheetExists = False
    
    ' シート名が「Summary」のシートが既に存在するかどうかを判定する
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = sheetName Then
            sheetExists = True
            Exit For
        End If
    Next ws
    
    ' もし同じ名前のシートが存在する場合は、それを削除する
    If sheetExists Then
        Application.DisplayAlerts = False
        ThisWorkbook.Worksheets(sheetName).Delete
        Application.DisplayAlerts = True
    End If
    
    ' 最後に「Summary」シートを作成する
    Set summarySheet = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    summarySheet.Name = sheetName
   
    ' 処理が完了したら、「Summary」シートをアクティブにする
    summarySheet.Activate

    '----------------------------------------------------------------------------------------------
    ''「Summary」シートにデータ出力
    '----------------------------------------------------------------------------------------------
    Dim t_offset As Long
    Dim b_Itemflg As Boolean '初日以降:True,初日:False
    Dim b_ItemNonExist As Boolean '存在:False,存在しない:True
    Dim l_start As Long      '人毎のデータ開始位置
   
    summarySheet.Cells(1, 1).value = "名前"
    summarySheet.Cells(1, 2).value = "項目"
    summarySheet.Cells(1, 3).value = "コスト"
    summarySheet.Cells(1, 4).value = "日付"

    '初期化
    olddd = myDicOut(CStr(1)).Dd   '日付の初期化
    lng_ii = 1                 '設定行の初期化
    l_start = 1
    t_offset = 4
    b_Itemflg = False
    b_ItemNonExist = True '存在しない
    oldName = myDicOut(CStr(1)).Name

    For lng_i = 1 To tid - 1 '最終データまで

        '日付の変更
        If olddd <> myDicOut(CStr(lng_i)).Dd Then
           t_offset = t_offset + 1 '日付のカラム位置
           b_Itemflg = True
        End If
        
        '名前の変更
        If oldName <> myDicOut(CStr(lng_i)).Name Then
            t_offset = 4
            l_start = lng_ii
            b_Itemflg = False
            b_ItemNonExist = True
        End If

        ''データの表示
        '初日以降なら項目を探す
        If b_Itemflg Then
            For lng_j = l_start To lng_i '
                If summarySheet.Cells(lng_j + 2, 2) = myDicOut(CStr(lng_i)).Item Then
                    summarySheet.Cells(lng_j + 2, t_offset) = myDicOut(CStr(lng_i)).Cost
                    b_ItemNonExist = False '項目が存在
                End If
            Next lng_j
            If b_ItemNonExist Then
                Call SubSetcsItemcost2(summarySheet, lng_ii, t_offset, lng_i)
                '行の初期化
                lng_ii = lng_ii + 1
            End If
            b_ItemNonExist = True
        Else
            Call SubSetcsItemcost2(summarySheet, lng_ii, t_offset, lng_i)
            '行の初期化
            lng_ii = lng_ii + 1
        End If
        summarySheet.Cells(2, t_offset) = myDicOut(CStr(lng_i)).Dd '日付
        '前回値
        olddd = myDicOut(CStr(lng_i)).Dd     '日付
        oldName = myDicOut(CStr(lng_i)).Name 'Name
    Next
End Sub


'----------------------------------------------------------------------------------------------
' 関数：csItemcost型データの入力
' csItemcost > myDic
'----------------------------------------------------------------------------------------------
Sub SubSetcsItemcost1(ByVal lng_out As Long, ByVal lng_in As Long)
    Dim p As csItemcost

    Set p = New csItemcost
    p.Name = myDic(CStr(lng_out)).Name
    p.Item = myDic(CStr(lng_out)).Item
    p.Cost = myDic(CStr(lng_out)).Cost
    p.Dd = myDic(CStr(lng_out)).Dd
    
    myDicOut.Add CStr(lng_in), p  'Noをキーにクラスを読み込み
    Set p = Nothing
End Sub
'----------------------------------------------------------------------------------------------
' 関数：summarySheetへデータ出力
' myDicOut > summarySheet
'----------------------------------------------------------------------------------------------
Sub SubSetcsItemcost2(summarySheet As Worksheet, ByVal lng_in As Long, ByVal lng_offset As Long, ByVal lng_out As Long)

    summarySheet.Cells(lng_in + 2, 1) = myDicOut(CStr(lng_out)).Name
    summarySheet.Cells(lng_in + 2, 2) = myDicOut(CStr(lng_out)).Item
    summarySheet.Cells(lng_in + 2, lng_offset) = myDicOut(CStr(lng_out)).Cost

End Sub

以上です、お疲れ様です。