VBA 照合集計転記その2

実現したいこと

・実績.xlsmから以下内容が実行されるマクロを作成したい為、ご協力をお願いします。
ステップ1：実績.xlsmから生産性_詳細.xlsxへ転記
ステップ2：予算書.xlsxから生産性_詳細.xlsxへ転記

前提

・実績.xlsm（転記元1）、予算書.xlsx（転記元2）、生産性_詳細.xlsx（転記先）は同一階層フォルダに保管
➀転記元1の作業項目は、転記時は同一名称を1つに集約
⇒イメージの場合、サブ組1のセルC6、C7をC2に集約
②転記元1の製番、型式は、転記時は➀の行数に合わせる。
⇒イメージの場合、セルA6:B6～A22:B22をセルA2:B2～A9:B9に集約
③転記元1の開始月日は、転記時は同一製番で一番古い年月日を1つ抽出
⇒イメージ図の場合、セルD2は2024/3/13になります。
④転記元1の完了月日は、転記時は同一製番で一番新しい年月日を1つ抽出
⇒イメージ図の場合、セルE2は2024/3/14になります。
⑤転記元1の作業時間[min]は、転記時は同一製番、作業の合算
⇒イメージ図の場合、セルF2は300（サブ組1）となります。
⑥転記元2の目標[min]は、転記時は同一型式、作業へ合算
⇒イメージ図の場合、セルF2は100（サブ組1）となります。
・実績.xlsmのデータが今後増えるため、高速処理できるコードを目指したいです。

該当のソースコード

VBA

1Sub 照合転記2() 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 lastwrowS As Long 9 Dim lastwrowC As Long 10 Dim lastwrowY As Long 11 Dim wrowY As Long 12 Dim keyY As String 13 Dim subWorkY As String 14 Dim targetTime As Long 15 Dim YwDic As Object 16 Set Swb = ThisWorkbook 17 Set Sws = Swb.Sheets("実績") 18 Set Ywb = Workbooks.Open(ThisWorkbook.Path & "\予算書.xlsx") 19 Set Yws = Ywb.Sheets("DB") 20 Set YwDic = CreateObject("Scripting.Dictionary") 21 'ステップ1予算書のデータを変数格納 22 lastwrowY = Yws.Cells(Rows.Count, "A").End(xlUp).Row ' 予算の最終行を取得 23 For wrowY = 2 To lastwrowY 24 keyY = Yws.Cells(wrowY, 1).Value 25 subWorkY = Yws.Cells(wrowY, 2).Value 26 targetTime = Yws.Cells(wrowY, 3).Value 27 28 If Not YwDic.exists(keyY) Then 29 YwDic.Add keyY, CreateObject("Scripting.Dictionary") 30 End If 31 32 YwDic(keyY)(subWorkY) = targetTime 33 Next wrowY 34 Ywb.Close 35 36 'ステップ2生産性_詳細ファイルへ必要情報を転記 37 Set Cwb = Workbooks.Open(ThisWorkbook.Path & "\生産性_詳細.xlsx") ' 生産性_詳細ファイルを開く 38 Set Cws = Cwb.Sheets("Sheet1") 39 Cws.Rows("2:" & Rows.Count).ClearContents 40 41 lastwrowS = Sws.Cells(Rows.Count, "A").End(xlUp).Row ' 実績の最終行を取得 42 lastwrowC = 2 43 44 Set Mydic = CreateObject("Scripting.Dictionary") 45 For wrowS = 6 To lastwrowS 46 mykey = Sws.Cells(wrowS, "A").Value 47 If Mydic.exists(mykey) = False Then ' 48 wrowC = lastwrowC 49 Cws.Cells(wrowC, "A").Value = Sws.Cells(wrowS, "A").Value '製番 50 Cws.Cells(wrowC, "B").Value = Sws.Cells(wrowS, "B").Value '型式 51 Cws.Cells(wrowC, "C").Value = Sws.Cells(wrowS, "C").Value '作業 52 Cws.Cells(wrowC, "D").Value = Sws.Cells(wrowS, "E").Value '開始年月日 53 Cws.Cells(wrowC, "E").Value = Sws.Cells(wrowS, "G").Value '完了年月日 54 Cws.Cells(wrowC, "G").Value = Sws.Cells(wrowS, "J").Value '作業時間 55 '目標時間 56 keyY = Sws.Cells(wrowS, "B").Value 57 If YwDic.exists(keyY) = False Then 58 MsgBox ("予算書.xlsx内に" & keyY & "が存在しない①") 59 Exit Sub 60 End If 61 Cws.Cells(wrowC, "F").Value = targetTime '目標YwDic(keyY) 62 Mydic(mykey) = lastwrowC 63 lastwrowC = lastwrowC + 1 64 Else 65 wrowC = Mydic(mykey) 66 '開始年月日更新 67 If Sws.Cells(wrowS, "E").Value < Cws.Cells(wrowC, "D").Value Then 68 Cws.Cells(wrowC, "D").Value = Sws.Cells(wrowS, "E").Value 69 End If 70 '完了年月日更新 71 If Sws.Cells(wrowS, "G").Value > Cws.Cells(wrowC, "E").Value Then 72 Cws.Cells(wrowC, "E").Value = Sws.Cells(wrowS, "G").Value 73 End If 74 '作業時間加算 75 Cws.Cells(wrowC, "G").Value = Cws.Cells(wrowC, "G").Value + Sws.Cells(wrowS, "J").Value 76 End If 77 Next 78 Cwb.Save 79 Cwb.Close 80 MsgBox ("完了") 81 82End Sub

試したこと

・連想配列にて、予算書から複数アイテムを保持しようと試みましたが出来ませんでした。

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

・先日、同様の質問をさせていただき解決しましたが、今回のケースでも躓いた為質問させていただきます。

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