■やりたいこと
・１週間分の勤怠データをまとめて表示する
１シート事に１日の工数データが記載された全シートのデータを１週間分にまとめて、”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
以上です、お疲れ様です。