VBA 照合集計転記

実現したいこと

・実績.xlsmから以下内容が実行されるマクロを作成したい。
ステップ1：実績.xlsmから生産性_全体.xlsxへ転記
ステップ2：予算書.xlsxから生産性_全体.xlsxへ転記

前提

・実績.xlsm、予算書.xlsx、生産性_全体.xlsxは同一階層フォルダに保管
・実績.xlsm
・製番、型式は同一名称を1つに集約
・開始月日は、同一製番で一番古い年月日を1つ抽出
※イメージ図の場合、セルC2は2024/3/13になります。
・完了月日は、同一製番で一番新しい年月日を1つ抽出
※イメージ図の場合、セルD2は2024/3/29になります。
イメージ図上、2024/3/29は隠れています。
・作業時間[min]は、同一製番の場合合算
※イメージ図の場合、セルF2は2835となります。
・目標[min]は、同一型式の場合合算
※イメージ図の場合、セルE2は1800となります。
・実績.xlsmのデータが今後増えるため、高速処理できるコードを目指したいです。

該当のソースコード

VBA

1Sub 照合転記() 2 Dim Swb As Workbook '実績ファイル 3 Dim Sws As Worksheet '実績ファイル実績シート 4 Dim Cwb As Workbook '生産性_全体ファイル 5 Dim Cws As Worksheet '生産性_全体ファイルSheet1シート 6 Dim Ywb As Workbook '予算ファイル 7 Dim Yws As Worksheet '予算ファイルDBシート 8 Dim lastRowS As Long 9 Dim lastRowC As Long 10 Dim RowTC As Long 11 Dim i As Long 12 Dim j As Long 13 Dim Mydic As Object 14 Dim Mykeys, Myitems 15 16 Set Swb = ThisWorkbook 17 Set Sws = Swb.Sheets("実績") 18 19 Set Cwb = Workbooks.Open(ThisWorkbook.Path & "\生産性_全体.xlsx") ' 生産性_全体.xlsxを開く 20 Set Cws = Cwb.Sheets("Sheet1") 21 Cws.Range(Cws.Range("A2"), Cws.Range("A" & Cws.Cells.Rows.Count)).EntireRow.Delete '2行目以降を削除 22 23 lastRowS = Sws.Cells(Sws.Rows.Count, "A").End(xlUp).Row ' 実績の最終行を取得 24 lastRowC = Cws.Cells(Cws.Rows.Count, "A").End(xlUp).Row ' 生産性_全体の最終行を取得 25 26 Set Mydic = CreateObject("Scripting.Dictionary") 27 On Error Resume Next 28 For i = 6 To lastRowS 29 If Not IsEmpty(Sws.Cells(i, 1).Value) Then 30 Mydic.Add Sws.Cells(i, 1).Value, Sws.Cells(i, 2).Value 31 End If 32 Next i 33 On Error GoTo 0 34 35 For j = 0 To Mydic.Count - 1 36 Mykeys = Mydic.Keys 37 Myitems = Mydic.Items 38 Cws.Cells(j + 2, 1).Value = Mykeys(j) 39 Cws.Cells(j + 2, 2).Value = Myitems(j) 40 Next j 41 42 Set Mydic = Nothing 43 44 Cwb.Save 45 Cwb.Close 46End Sub 47 48

試したこと

・連想配列を見様見真似で作成しましたが、転記したいアイテムが複数ある事と、
各項目毎に条件があり、解決方法が分からなくご相談させていただきました。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。