ここから追加改良をお願いしたいです、どなたか教えていただければ幸です。 以下、条件と実施したいこと ■転記の元となるシート（エクセル①） ・特定のフォルダにいれています。（例えばファイルパス"\￥○○\○○\"など） ・エクセル①のシート名の"データ"から各エクセルに転記したいです ・H3に日付がはいっています ・C4：C180まで会社名がきさいされています【key1とします】 ・D4：D180まで地域がきさいされています【key2とします】 ・H4：H180まで数値がはいっています 上記のデータを元に各エクセルに転記したいです。 専用の転記ブックより転記したいです【画像赤枠】 画像イメージをみてもらえると理解していただけるかと思います。 以下のコードにKey2の条件を追加したいです。 Dim R1, EndR1, C1, EndC1 Dim Hiduke Dim WsM As Worksheet Dim Ws1 As Worksheet, Wb1 As Workbook Dim Rng As Range Dim Path, WbX As Workbook, WsX As Worksheet Dim CX, RX Dim Dic1 As Object, Key, Item, DicK As Object Set Dic1 = CreateObject("Scripting.Dictionary") Set WsM = ActiveSheet Path = WsM.Cells(2, 2).Text & WsM.Cells(2, 1).Text Set Wb1 = Workbooks.Open(Path) Set Ws1 = Wb1.Worksheets(WsM.Cells(2, 3).Text) Hiduke = Ws1.Range(WsM.Cells(2, 4).Text) For Each Rng In Ws1.Range(WsM.Cells(2, 5).Text) Key = Rng.Text R1 = Rng.Row Item = Ws1.Range(WsM.Cells(2, 6).Text & R1) If Dic1.exists(Key) = False Then Dic1.Add Key, Item Else MsgBox "データシートの会社名に重複があります。", vbCritical End End If Next Application.ScreenUpdating = False EndR1 = WsM.Cells(Rows.Count, 1).End(xlUp).Row For R1 = 5 To EndR1 Path = WsM.Cells(R1, 2) & WsM.Cells(R1, 1) Set WbX = Workbooks.Open(Path) Set WsX = WbX.Worksheets(WsM.Cells(R1, 3).Text) For Each Rng In WsX.Range(WsM.Cells(R1, 4).Text) If Rng = Hiduke Then CX = Rng.Column Exit For End If Next EndC1 = WsM.Cells(R1, Columns.Count).End(xlToLeft).Column For C1 = 5 To EndC1 For Each Rng In WsX.Range(WsM.Cells(R1, C1).Text) Key = Rng.Text If Dic1.exists(Key) Then RX = Rng.Row WsX.Cells(RX, CX) = Dic1(Key) End If Next Next C1 Application.DisplayAlerts = False WbX.Close True Application.DisplayAlerts = True Next R1 Application.DisplayAlerts = False Wb1.Close True Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "終了" End Sub
