Excel VBA 逆引き集 | マスタ結合結果を新シートへ

Excel VBA
スポンサーリンク

マスタ結合結果を新シートへ

「JOIN（結合）した結果を、既存の表を壊さず“新しいシート”に綺麗に出力したい」——初心者でも安定して使えるテンプレをまとめました。要点は「安全にシートを用意」「配列で一括貼り付け」「ヘッダー・書式・監査を整える」です。

安全に新シートを用意（作成・再利用・クリア）

Option Explicit

'指定名のシートを返す。なければ作成。clear:=Trueならクリアしてから返す
Public Function EnsureSheet(ByVal sheetName As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = sheetName
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function
VB
  • ポイント
    • 存在確認→作成: 何度実行しても安全。
    • クリア制御: 追記運用なら clear:=False にできる。

単一キーJOIN→新シートに一括出力（基本テンプレ）

「明細にマスタ項目を付与して、新シート“統合結果”に出力」する最短の実用コードです。

Sub JoinToNewSheet_Basic()
    '明細: Sheet("明細") A=コード, B=数量
    'マスタ: Sheet("マスタ") A=コード, B=名称, C=単価
    '出力: Sheet("統合結果")に（コード, 名称, 単価, 数量, 金額）

    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")
    Dim rgD As Range: Set rgD = wsD.Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = wsM.Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vM As Variant: vM = rgM.Value

    'マスタ辞書（コード→(名称,単価)）
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vM, 1)
        key = UCase$(Trim$(CStr(vM(i, 1))))
        If Len(key) > 0 Then dict(key) = Array(CStr(vM(i, 2)), CDbl(Val(vM(i, 3))))
    Next

    '出力配列（ヘッダー含む）
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 5)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額"

    Dim r As Long
    For r = 2 To UBound(vD, 1)
        Dim cd As String: cd = UCase$(Trim$(CStr(vD(r, 1))))
        Dim qty As Double: qty = CDbl(Val(vD(r, 2)))
        out(r, 1) = vD(r, 1)         'コード（元の表記）
        out(r, 4) = qty              '数量
        If dict.Exists(cd) Then
            out(r, 2) = dict(cd)(0)                  '名称
            out(r, 3) = dict(cd)(1)                  '単価
            out(r, 5) = dict(cd)(1) * qty            '金額
        Else
            out(r, 2) = "#N/A"
            out(r, 3) = 0
            out(r, 5) = 0
        End If
    Next

    '新シートへ貼り付け＋書式
    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("統合結果", True)
    wsOut.Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
    wsOut.Columns.AutoFit
    wsOut.Range("C2:C" & UBound(out, 1)).NumberFormat = "#,##0.00" '単価
    wsOut.Range("E2:E" & UBound(out, 1)).NumberFormat = "#,##0"    '金額
    wsOut.Rows(1).Font.Bold = True
End Sub
VB
  • ポイント
    • 配列＋辞書: セル往復ゼロで速い。
    • 未一致は見える化: 名称は「#N/A」、数値は0で補完。
    • 出力整形: ヘッダー太字・列幅・数値書式。

見出し名で安全にJOIN→新シート（列順変更に強い）

列順や列追加がありそうなら、見出し名から列を取得して壊れないテンプレを使います。

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function

Sub JoinToNewSheet_ByHeaders()
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")
    Dim rgD As Range: Set rgD = wsD.Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = wsM.Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vM As Variant: vM = rgM.Value

    '見出し位置
    Dim cKeyD As Long: cKeyD = FindHeader(rgD.Rows(1), "コード")
    Dim cQtyD As Long: cQtyD = FindHeader(rgD.Rows(1), "数量")
    Dim cKeyM As Long: cKeyM = FindHeader(rgM.Rows(1), "コード")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cPriceM As Long: cPriceM = FindHeader(rgM.Rows(1), "単価")
    If cKeyD * cQtyD * cKeyM * cNameM * cPriceM = 0 Then
        MsgBox "見出し不足（コード/数量/名称/単価）": Exit Sub
    End If

    '辞書（コード→(名称,単価)）
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vM, 1)
        key = UCase$(Trim$(CStr(vM(i, cKeyM))))
        dict(key) = Array(CStr(vM(i, cNameM)), CDbl(Val(vM(i, cPriceM))))
    Next

    '出力配列
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 5)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額"

    Dim r As Long
    For r = 2 To UBound(vD, 1)
        Dim cd As String: cd = UCase$(Trim$(CStr(vD(r, cKeyD))))
        Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
        out(r, 1) = vD(r, cKeyD)
        out(r, 4) = qty
        If dict.Exists(cd) Then
            out(r, 2) = dict(cd)(0)
            out(r, 3) = dict(cd)(1)
            out(r, 5) = dict(cd)(1) * qty
        Else
            out(r, 2) = "#N/A": out(r, 3) = 0: out(r, 5) = 0
        End If
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("統合結果", True)
    wsOut.Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
    wsOut.Columns.AutoFit
    wsOut.Rows(1).Font.Bold = True
End Sub
VB
  • ポイント
    • 壊れない列参照: 見出し名で動的に特定。
    • 異常早期検知: 見出し不足ならメッセージで停止。

監査・ログを同時出力（未一致・重複を可視化）

結合結果を新シートに出しつつ、監査ログ（未一致や重複キー）も別シートに残せます。

Sub JoinWithAudit_ToNewSheet()
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")
    Dim vD As Variant: vD = wsD.Range("A1").CurrentRegion.Value
    Dim vM As Variant: vM = wsM.Range("A1").CurrentRegion.Value

    '辞書（コード→(名称,単価)）＋重複検知
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim dup As Object: Set dup = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vM, 1)
        k = UCase$(Trim$(CStr(vM(i, 1))))
        If dict.Exists(k) Then dup(k) = True Else dict(k) = Array(CStr(vM(i, 2)), CDbl(Val(vM(i, 3))))
    Next

    '出力
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 5)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額"

    Dim miss As Object: Set miss = CreateObject("Scripting.Dictionary")
    Dim r As Long
    For r = 2 To UBound(vD, 1)
        Dim cd As String: cd = UCase$(Trim$(CStr(vD(r, 1))))
        Dim qty As Double: qty = CDbl(Val(vD(r, 2)))
        out(r, 1) = vD(r, 1)
        out(r, 4) = qty
        If dict.Exists(cd) Then
            out(r, 2) = dict(cd)(0)
            out(r, 3) = dict(cd)(1)
            out(r, 5) = dict(cd)(1) * qty
        Else
            out(r, 2) = "#N/A": out(r, 3) = 0: out(r, 5) = 0
            miss(cd) = True
        End If
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("統合結果", True)
    wsOut.Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
    wsOut.Columns.AutoFit: wsOut.Rows(1).Font.Bold = True

    '監査ログ
    Dim wsLog As Worksheet: Set wsLog = EnsureSheet("結合監査", True)
    wsLog.Range("A1:B1").Value = Array("未一致キー", "マスタ重複キー")
    Dim r1 As Long: r1 = 2
    Dim x As Variant
    For Each x In miss.Keys: wsLog.Cells(r1, 1).Value = x: r1 = r1 + 1: Next
    Dim r2 As Long: r2 = 2
    For Each x In dup.Keys: wsLog.Cells(r2, 2).Value = x: r2 = r2 + 1: Next
    wsLog.Columns.AutoFit
End Sub
VB
  • ポイント
    • 未一致キー: 明細にあるのにマスタに無いキー。
    • 重複キー: マスタ側で同じキーが複数行あるもの。

追記運用（既存の“統合結果”に足していく）

「毎日分を積み上げたい」場合は、ヘッダー整合を確認しつつ末尾へ追記します。

Sub AppendJoinResult_ToExistingSheet()
    '事前に「統合結果」シートが存在し、A1:E1にヘッダーが揃っている前提
    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("統合結果", False)

    '新規結果を作成（基本テンプレの出力配列 out を得たと仮定）
    '↓↓ 実務では JoinToNewSheet_Basic の中身を「配列を返す関数」にして呼び出すのが綺麗
    Dim out() As Variant
    '... out を作る処理（省略） ...

    'ヘッダー整合チェック（A1:E1に一致しているか確認）
    If wsOut.Cells(1, 1).Value <> "コード" Or wsOut.Cells(1, 2).Value <> "名称" Then
        MsgBox "統合結果のヘッダーが期待と異なります": Exit Sub
    End If

    '末尾行に追記
    Dim last As Long: last = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp).Row
    wsOut.Range("A" & last + 1).Resize(UBound(out, 1) - 1, UBound(out, 2)).Value = _
        WorksheetFunction.Index(out, Evaluate("ROW(2:" & UBound(out, 1) & ")"), Evaluate("COLUMN(1:" & UBound(out, 2) & ")"))
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • ヘッダー確認: 追記先が崩れていないか必ずチェック。
    • 配列の2行目以降だけ貼る: 1行目はヘッダーなので除外。

実務の仕上げ小ワザ

  • 出力にタイムスタンプ列:
    • 例: 実行日時や処理バージョンを列Fに入れて追跡可能に。
  • 数値書式の統一:
    • 例: 単価は「#,##0.00」、金額は「#,##0」など。
  • 安全ラップで高速安定:
    • 例: 前後に ScreenUpdating=False、Calculation=Manual を入れて戻す。
  • エクスポート（CSVや新ブック）:
    • 例: 出力シートを新ブックにコピー→保存して配布用に。

例題で練習

'例1：基本JOINを新シート「統合結果」へ
Sub Example_JoinBasic()
    JoinToNewSheet_Basic
End Sub

'例2：見出し名で安全にJOINして新シートへ
Sub Example_JoinByHeaders()
    JoinToNewSheet_ByHeaders
End Sub

'例3：JOIN＋監査ログを新シートに同時出力
Sub Example_JoinWithAudit()
    JoinWithAudit_ToNewSheet
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました