条件にあうセルを別シートへ転記・行挿入して貼付け

投稿者 : hana     投稿日時 : 2026/04/13(Mon) 16:52:25     OS : Windows 11     EXCEL : Office 365

---

3つのシートの情報を別の1つのシートにまとめたいのですが手入力だと膨大なデータ量のためミスが発生しそうなのでマクロを組めたら組みたいです。
どなたか教えていただけませんでしょうか・・・

下記＜ファイル名：原本＞にデータを集約して貼付けしていきたいのですが
別の年のシートから同じ商品が同じ得意先にでていた場合E～G列に数量を入れたいです。

同じ商品が別の得意先出ていた場合は同じ商品コードの下に行挿入して列を転記していきたいです。



●元のシートの書式＜ファイル名：原本＞

　　　A　　　　　B　　　　　C　　　　　　D　　　　E　　　　　F　　　　G

1　商品コード　商品名　得意先コード　得意先名　2024数量　2025数量　2026数量

2　　1111　　　いちご

3　　2222　　　りんご

4　　3333　　　ばなな


●2024年出荷数量＜ファイル名：2024＞

　　　A　　　　　B　　　　　C　　　　　　D　　　　E　　　

1　商品コード　商品名　得意先コード　得意先名　　数量　

2　　1111　　　いちご　　　0001　　　　山田　　　　5

3　　2222　　　りんご　　　0002　　　　佐藤　　　　2

4　　3333　　　ばなな　　　0003　　　　鈴木　　　　4


●2025年出荷数量＜ファイル名：2025＞

　　　A　　　　　B　　　　　C　　　　　　D　　　　E　　　

1　商品コード　商品名　得意先コード　得意先名　　数量　

2　　1111　　　いちご　　　0001　　　　山田　　　　3

3　　3333　　　ばなな　　　0004　　　　加藤　　　　2



●2026年出荷数量＜ファイル名：2026＞

　　　A　　　　　B　　　　　C　　　　　　D　　　　E　　　

1　商品コード　商品名　得意先コード　得意先名　　数量　

2　　1111　　　いちご　　　0001　　　　山田　　　　4

3　　2222　　　りんご　　　0002　　　　佐藤　　　　1


↓マクロ起動後の原本

　　　A　　　　　B　　　　　C　　　　　　D　　　　E　　　　　F　　　　G

1　商品コード　商品名　得意先コード　得意先名　2024数量　2025数量　2026数量

2　　1111　　　いちご　　　0001　　　　山田　　　　5　　　　　3　　　　4

3　　2222　　　りんご　　　0002　　　　佐藤　　　　2　　　　　　　　 　1

4　　3333　　　ばなな　　　0003　　　　鈴木　　　　4

5　　3333　　　ばなな　　　0004　　　　加藤　　　　　　　　　 2

投稿者 : ピロリ     投稿日時 : 2026/04/13(Mon) 19:25:41

---

マクロは、原本ブック（原本.xlsm）に記述されていて、アクティブシートへ数量データを読み込む前提です。
また、各年のブック名は 2024.xlsx，2025.xlsx，2026.xlsx とし、すでに開いている状態で、数量データは
アクティブシートに入力されている前提です。
処理は、各年の全データを読み込み、商品コードと得意先コードが同じ行は数量データを転記し１行に纏める。
最終的に商品コードと得意先コードをキーにして、データをソートするって処理にしてます。　参考になれば。

Sub Sample()
    Dim 原本 As Worksheet, 数量 As Worksheet
    Dim i As Long, j As Long, k As Long, cnt As Long
    'マクロは原本ブックに記載され、アクティブシートへ集計する前提
    Set 原本 = ThisWorkbook.ActiveSheet
    With 原本
        '原本ブックへ全年の数量データを転記する
        cnt = 2
        For i = 5 To .Cells(1, Columns.Count).End(xlToLeft).Column
            '年毎のブックは開いた状態で、数量データはアクティブシートに入力されている前提
            Set 数量 = Workbooks(Left(.Cells(1, i), 4) & ".xlsx").ActiveSheet
            For j = 2 To 数量.Cells(Rows.Count, "A").End(xlUp).Row
                .Rows(2).Copy .Rows(cnt)
                .Rows(cnt).ClearContents
                For k = 1 To 4
                    .Cells(cnt, k) = 数量.Cells(j, k)
                Next k
                .Cells(cnt, i) = 数量.Cells(j, "E")
                cnt = cnt + 1
            Next j
        Next i
        '商品コードと得意先コードが同じ行は、数量データを転記して行削除する
        For i = .Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
            For j = i - 1 To 2 Step -1
                If .Cells(i, "A") = .Cells(j, "A") And .Cells(i, "C") = .Cells(j, "C") Then
                    For k = 5 To .Cells(i, Columns.Count).End(xlToLeft).Column
                        If .Cells(i, k) <> "" Then .Cells(j, k) = .Cells(i, k)
                    Next k
                    .Rows(i).Delete
                    Exit For
                End If
            Next j
        Next i
        '商品コードと得意先コードをキーにしてデータソートする
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending
        .Sort.SortFields.Add Key:=.Range("C1"), Order:=xlAscending
        .Sort.SetRange .Range("A1:J11")
        .Sort.Header = xlYes
        .Sort.Apply
    End With
End Sub

投稿者 : ピロリ     投稿日時 : 2026/04/13(Mon) 19:47:16

---

■[返信 1] の記事
＞ 処理は、各年の全データを読み込み、商品コードと得意先コードが同じ行は数量データを転記し１行に纏める。
＞ 最終的に商品コードと得意先コードをキーにして、データをソートするって処理にしてます。
なので「同じ商品が別の得意先出ていた場合は同じ商品コードの下に行挿入して列を転記」って処理にはしていません。
その処理が必須ってことであれば、他の方のご意見をお待ち下さい。

投稿者 : ピロリ     投稿日時 : 2026/04/14(Tue) 06:00:03

---

■[返信 1] の記事
テストデータが残っていたので、修正（38step目）をお願いします。
　　　　.Sort.SetRange .Range("A1:J11")
　　　　　　　　　　　　　↓
　　　　.Sort.SetRange .UsedRange
失礼しました。

投稿者 : anonymous     投稿日時 : 2026/04/15(Wed) 07:00:23

---

こんな書き方もできると思います。

Sub test()
    Dim dic As Object
    Dim wb As Workbook, ws As Worksheet
    Dim colToWrite&, pos&, p&, key$
    Dim i&, k&

    Set dic = CreateObject("Scripting.Dictionary")
    pos = 1     '原本シートに書き出す行の行番号(2から開始）
    With ThisWorkbook.Sheets("Sheet1")
        .Range("A1").CurrentRegion.Offset(1).ClearContents     '見出し以外を事前に消去
        For i = 5 To .Cells(1, Columns.Count).End(xlToLeft).Column
            Set wb = Workbooks(Left(.Cells(1, i), 4) & ".xlsx")
            Set ws = wb.Sheets(1)
            colToWrite = i
            For k = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
                key = ws.Cells(k, "A") & "_" & ws.Cells(k, "C")
                If Not dic.Exists(key) Then
                    pos = pos + 1
                    dic(key) = pos
                    ws.Cells(k, "A").Resize(1, 4).Copy .Cells(pos, "A")
                    .Cells(pos, colToWrite) = ws.Cells(k, "E")
                Else
                    p = dic(key)
                    .Cells(p, colToWrite) = .Cells(p, colToWrite) + ws.Cells(k, "E")
                End If
            Next
        Next

        '商品コードと得意先コードをキーにしてソート
        .Sort.SortFields.Clear
        .Sort.SortFields.Add key:=.Range("A1"), Order:=xlAscending
        .Sort.SortFields.Add key:=.Range("C1"), Order:=xlAscending
        .Sort.SetRange .Range("A1").CurrentRegion
        .Sort.Header = xlYes
        .Sort.Apply
    End With
End Sub

同一年度で、同一キー(商品cd + 得意先cd)のデータが複数ある場合は、加算するようにしています。（念のため）

投稿者 : hana     投稿日時 : 2026/04/15(Wed) 16:19:19

---

ピロリ様、anonymous様　ありがとうございます！！
例で作成していただいたコードを紐解いて自分の作成したい資料で使用できるように解読してみます！

少し時間がかかりそうですが、もし分からないところがあれば
また質問させていただきたいです・・・！

お早いご回答ありがとうございます・・・！

投稿者 : anonymous     投稿日時 : 2026/04/16(Thu) 07:00:01

---

うまくいかない場合は勿論、「うまくいった場合」も「必ず」結果報告してください。
そうした報告は、回答者や閲覧者に対して質問者がなしうる貢献のひとつです。
　　　　　　　　　　　　　　　　　　　　　　　　　　 -- わが心は石にあらず --

投稿者 : hana     投稿日時 : 2026/04/16(Thu) 09:50:59

---

■[返信 6] anonymousさん（2026-04-16 07:00:01）の記事
＞ うまくいかない場合は勿論、「うまくいった場合」も「必ず」結果報告してください。
＞ そうした報告は、回答者や閲覧者に対して質問者がなしうる貢献のひとつです。
＞ 　　　　　　　　　　　　　　　　　　　　　　　　　　 -- わが心は石にあらず --

もちろんです！ありがとうございます^^

投稿者 : hana     投稿日時 : 2026/04/16(Thu) 16:19:12

---

ピロリ様、anonymous様

コードもばっちり使用できて
無事作成したい資料をつくることができました！^^

ありがとうございました！^^