エクセルでIDを基準に2つの表を統合するマクロボタンを作る方法

あなたは2つの表をIDをベースに１つの表にまとめたいと思ったことはありませんか？

例えば、納期管理や工程管理など、A社とB社のそれぞれの表を1つにまとめるのに、共通するIDがあって、それをベースに2つの表を１つにまとめる作業って意外と面倒ですよね。

一つ一つコピペしたり、表をコピペして並び替えたり、IDごとにコピペしたり・・・数が多いと大変です。

A社の表をB社に提供して書き込んでもらうなどすればいいのですが、中々そうもできない場合もあります。

エクセルのマクロを使えば、IDを基準にして、2つの表を1つに統合するのを自動でできるので、かなり作業がラクになります。

今回は「エクセルでIDを基準に2つの表を統合するマクロボタンを作る方法」を紹介します。

エクセルでIDを基準に2つの表を統合するマクロボタンを作る方法
IDの並び順が違ったり、数が違ったりした場合
表1にしかIDがない場合や、表2にしかない項目を統合に反映する場合
まとめ

エクセルでIDを基準に2つの表を統合するマクロボタンを作る方法

エクセルでIDを基準に2つの表を統合するマクロボタンを作る方法です。

これが統合したいデータです。

IDは共通していますが、他の項目で違うところがあります。

これをIDベースに1つの表にまとめるのを例に紹介します。

（２つの表（テーブル）を１つに結合するので、テーブル結合と言ったりします。）

マクロを作るときは、「開発」タブを使います。
開発タブが出ていない方は、下のリンクで出し方を紹介していますので、まずは準備をお願いします。
→エクセルで開発タブを表示する方法

１．「開発」タブをクリック　→「挿入」をクリック　→「ボタン」をクリック

２．「新規作成」をクリック

３．コード入力画面が開く

４．コードを入力

コードを入力します。

Sheet3に、表1と表2を貼り付ける、という意味です。

赤枠部のコードです。

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
    Dim cell As Range, rng1 As Range, rng2 As Range
    Dim foundCell As Range
    Dim ws3Row As Long
    
    ' ワークシートを設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1") ' 表1があるシート
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' 表2があるシート
    Set ws3 = ThisWorkbook.Sheets.Add ' 新しい表（表3）を作成
    
    ' 表1と表2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    
    ' 表1のデータを表3にコピー
    ws1.Range("A1:D" & lastRow1).Copy Destination:=ws3.Range("A1")
    
    ' 表3の最終行を取得
    lastRow3 = ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row
    
    ' 表2のデータを検索して表3に追加
    Set rng1 = ws1.Range("A2:A" & lastRow1)
    Set rng2 = ws2.Range("A2:A" & lastRow2)
    
    For Each cell In rng2
        Set foundCell = rng1.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not foundCell Is Nothing Then
            ' 一致するIDが見つかった場合、表2のデータを表3に追加
            ws2.Range("B" & cell.Row & ":D" & cell.Row).Copy
            ws3.Range("E" & foundCell.Row).PasteSpecial Paste:=xlPasteValues
        Else
            ' 一致しない場合、表2のデータを表3の最後に追加
            ws3Row = lastRow3 + 1
            ws2.Range("A" & cell.Row & ":D" & cell.Row).Copy
            ws3.Range("A" & ws3Row).PasteSpecial Paste:=xlPasteValues
            lastRow3 = ws3Row
        End If
    Next cell
    
    MsgBox "データの統合が完了しました。", vbInformation

コードを入力したら、コードの入力画面を閉じて下さい。

５．ボタンができた　→ボタンをクリック

ボタンができたら、ボタンをクリックします。

６．表の統合が完了

表1の隣に、表2のデータを貼り付けるような形で、表を統合できました。

次の画像で、書き項目を修正等しています。

・日付がシリアル値だったので、日付表示に修正しました。

・比較の為、表1と表2のデータを貼付けしました。

ちゃんと貼付けはできていますが、表2から貼り付けた箇所には見出しが欲しいですよね。

そこで、見出しが追加されるように修正しました。

これでボタンを押すと・・・

赤枠部分に見出しの貼り付けができました。

同じように日付表示を修正します。

あとは罫線など、表の体裁を整えれば、完了ですね。

IDの並び順が違ったり、数が違ったりした場合

次に、表1と表2でIDの並び順が違っていたり、表2だけ列が多かった場合のコードの紹介です。

＜表2＞

Sheet3に表1、表2をID基準にコピペ。表2にしかないIDがあった場合は追加する、という意味です。

コード入力ができたら、ボタンを押します。

こんな感じでIDの順番が変わったり、表2のみのIDがあっても、統合できました。

こちらはコピペ元のデータも比較の為、貼り付けしたところです。

表1にしかIDがない場合や、表2にしかない項目を統合に反映する場合

次に、表1にしかないIDがあったり、表2にしかない項目を、表3に統合するときに反映する場合です。

表1に新規IDを追加しました。

＜表1＞

表2に納期2の列を追加しました。

＜表2＞

コードも修正しました。

表1にしかないIDがあった場合は、表3に反映。表2のヘッダーを追加し、表3に反映、という意味です。

赤枠部のコードです。

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
    Dim i As Long, j As Long
    Dim found As Range

    ' 表1と表2のシートを指定
    Set ws1 = ThisWorkbook.Sheets("Sheet1") ' 表1のシート
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' 表2のシート
    
    ' 表3のシートを新しく追加
    Set ws3 = ThisWorkbook.Sheets.Add ' 新しい表（表3）を作成
    
    ' 表1の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    
    ' 表2の最終行を取得
    lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    
    ' ヘッダーを表3にコピー
    ws3.Range("A1:D1").Value = ws1.Range("A1:D1").Value ' 表1のヘッダー
    ws3.Range("E1:I1").Value = ws2.Range("B1:E1").Value ' 表2のヘッダー (ID列を除く)
    
    ' 表3の最終行を初期化
    lastRow3 = 1
    
    ' 表1のデータを表3に追加
    For i = 2 To lastRow1
        lastRow3 = lastRow3 + 1
        ws3.Range("A" & lastRow3 & ":D" & lastRow3).Value = ws1.Range("A" & i & ":D" & i).Value
        
        ' 表2で同じIDがあるかを確認
        Set found = ws2.Columns(1).Find(ws1.Cells(i, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not found Is Nothing Then
            ' 表2にIDがある場合、表1の行の右側に表2のデータを追加
            ws3.Range("E" & lastRow3 & ":I" & lastRow3).Value = ws2.Range("B" & found.Row & ":E" & found.Row).Value
        End If
    Next i
    
    ' 表2にのみ存在するデータを表3の下に追加
    For j = 2 To lastRow2
        Set found = ws1.Columns(1).Find(ws2.Cells(j, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        
        If found Is Nothing Then
            ' 表1にIDがない場合、表2のデータを新しい行に左詰めで追加
            lastRow3 = lastRow3 + 1
            ws3.Cells(lastRow3, 1).Value = ws2.Cells(j, 1).Value
            ws3.Range("E" & lastRow3 & ":I" & lastRow3).Value = ws2.Range("B" & j & ":E" & j).Value
        End If
    Next j
    
    ' 表3のカラム幅を自動調整
    ws3.Columns.AutoFit
    
    MsgBox "表の結合が完了しました。", vbInformation

これでボタンを押すと・・・

表3にそれぞれ反映できました。