Excel VBA 逆引き集 | JOIN 高速テンプレ（2段結合）

Excel VBA
スポンサーリンク

JOIN 高速テンプレ（2段結合）

「明細にマスタAを付けて、さらにマスタBを付けたい」「部門→担当者→価格表のように段階的に属性を横付けしたい」——2段（多段）JOINを高速・安全にこなすテンプレです。コツは「配列→辞書→一括貼付」「キーの正規化」「見出し名で列特定」「段ごとの監査ログ」。

共通ユーティリティ（速度・安全）

Option Explicit

Private Sub SpeedOn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function

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

Private Function NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function
VB
  • ポイント
    • 速度は「画面/イベント/計算を停止」→終了時復帰。
    • 見出し名で列特定して壊れにくく。
    • キーは Trim＋UCase で正規化して一致漏れ防止。

2段左結合（明細→マスタA→マスタB）

明細に「名称・単価（マスタA）」を付与し、さらに「カテゴリ・税率（マスタB）」を付与。未一致は見える化します。

Sub Join_TwoStage_Left()
    SpeedOn

    '明細: Sheet("明細") … コード, 数量
    'マスタA: Sheet("マスタA") … コード, 名称, 単価
    'マスタB: Sheet("マスタB") … コード, カテゴリ, 税率
    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgA As Range: Set rgA = Worksheets("マスタA").Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = Worksheets("マスタB").Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    '見出し列の取得
    Dim cKeyD As Long: cKeyD = FindHeader(rgD.Rows(1), "コード")
    Dim cQtyD As Long: cQtyD = FindHeader(rgD.Rows(1), "数量")
    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), "コード")
    Dim cNameA As Long: cNameA = FindHeader(rgA.Rows(1), "名称")
    Dim cPriceA As Long: cPriceA = FindHeader(rgA.Rows(1), "単価")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    Dim cCatB As Long:  cCatB  = FindHeader(rgB.Rows(1), "カテゴリ")
    Dim cTaxB As Long:  cTaxB  = FindHeader(rgB.Rows(1), "税率")
    If cKeyD*cQtyD*cKeyA*cNameA*cPriceA*cKeyB*cCatB*cTaxB = 0 Then SpeedOff: MsgBox "見出し不足": Exit Sub

    '辞書化（キー→配列）
    Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary")
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String

    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKeyA))
        If Len(k) > 0 Then dictA(k) = Array(CStr(vA(i, cNameA)), CDbl(Val(vA(i, cPriceA))))
    Next
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cKeyB))
        If Len(k) > 0 Then dictB(k) = Array(CStr(vB(i, cCatB)), CDbl(Val(vB(i, cTaxB))))
    Next

    '出力配列（明細基準）
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 8)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量"
    out(1, 5) = "金額": out(1, 6) = "カテゴリ": out(1, 7) = "税率": out(1, 8) = "ステータス"

    Dim r As Long
    For r = 2 To UBound(vD, 1)
        Dim keyD As String: keyD = NormKey(vD(r, cKeyD))
        Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
        Dim nameV As Variant, priceV As Double, catV As Variant, taxV As Double
        Dim st As String: st = ""

        out(r, 1) = vD(r, cKeyD)
        out(r, 4) = qty

        '段1：A付与
        If dictA.Exists(keyD) Then
            nameV = dictA(keyD)(0)
            priceV = dictA(keyD)(1)
        Else
            nameV = "#N/A": priceV = 0: st = st & "A未一致;"
        End If

        '段2：B付与
        If dictB.Exists(keyD) Then
            catV = dictB(keyD)(0)
            taxV = dictB(keyD)(1)
        Else
            catV = "": taxV = 0: st = st & "B未一致;"
        End If

        out(r, 2) = nameV
        out(r, 3) = priceV
        out(r, 5) = priceV * qty
        out(r, 6) = catV
        out(r, 7) = taxV
        out(r, 8) = IIf(st = "", "OK", st)
    Next

    With EnsureSheet("JOIN_2段_左結合", True)
        .Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
        .Range("E2:E" & UBound(out, 1)).NumberFormat = "#,##0"
        .Range("G2:G" & UBound(out, 1)).NumberFormat = "0.000"
    End With

    SpeedOff
End Sub
VB
  • ポイント
    • 段ごとに辞書化→横付け。 同じキーなら、A・Bの辞書を同じ正規化ルールで作成。
    • 監査列（ステータス）で未一致の段を一目で把握。

2段左結合（キーが違う段を連鎖）

段1で「商品コード→分類コード」を引き、段2は「分類コード→税率」を引く「キー連鎖」型です。

Sub Join_TwoStage_ChainedKeys()
    SpeedOn

    '明細: コード/数量
    'マスタA: コード/名称/分類コード
    'マスタB: 分類コード/カテゴリ/税率
    Dim vD As Variant: vD = Worksheets("明細").Range("A1").CurrentRegion.Value
    Dim vA As Variant: vA = Worksheets("マスタA").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("マスタB").Range("A1").CurrentRegion.Value

    '見出し列（簡略、必要ならFindHeader）
    Dim cKeyD As Long: cKeyD = 1
    Dim cQtyD As Long: cQtyD = 2
    Dim cKeyA As Long: cKeyA = 1
    Dim cNameA As Long: cNameA = 2
    Dim cClassA As Long: cClassA = 3
    Dim cClassB As Long: cClassB = 1
    Dim cCatB As Long:  cCatB  = 2
    Dim cTaxB As Long:  cTaxB  = 3

    '辞書
    Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary") '商品コード→(名称,分類コード)
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary") '分類コード→(カテゴリ,税率)
    Dim i As Long, k As String

    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKeyA))
        If Len(k) > 0 Then dictA(k) = Array(CStr(vA(i, cNameA)), CStr(vA(i, cClassA)))
    Next
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cClassB))
        If Len(k) > 0 Then dictB(k) = Array(CStr(vB(i, cCatB)), CDbl(Val(vB(i, cTaxB))))
    Next

    '出力
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 7)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "分類コード"
    out(1, 4) = "カテゴリ": out(1, 5) = "税率": out(1, 6) = "数量": out(1, 7) = "ステータス"

    Dim r As Long
    For r = 2 To UBound(vD, 1)
        Dim kd As String: kd = NormKey(vD(r, cKeyD))
        Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
        Dim status As String: status = ""

        out(r, 1) = vD(r, cKeyD)
        out(r, 6) = qty

        If dictA.Exists(kd) Then
            Dim nameA As String: nameA = dictA(kd)(0)
            Dim classCode As String: classCode = dictA(kd)(1)
            out(r, 2) = nameA
            out(r, 3) = classCode

            Dim kc As String: kc = NormKey(classCode)
            If dictB.Exists(kc) Then
                out(r, 4) = dictB(kc)(0)
                out(r, 5) = dictB(kc)(1)
            Else
                status = status & "B未一致;"
            End If
        Else
            out(r, 2) = "#N/A": out(r, 3) = ""
            status = status & "A未一致;"
        End If

        out(r, 7) = IIf(status = "", "OK", status)
    Next

    With EnsureSheet("JOIN_2段_キー連鎖", True)
        .Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With

    SpeedOff
End Sub
VB
  • ポイント
    • 段1の結果（分類コード）を段2のキーに使う「連鎖」設計。
    • 連鎖途中の未一致も監査列で把握。

2段結合＋複合キー（例：コード×年月→単価表→税率表）

年月で単価が変わる場合、複合キーを連結して段ごとに辞書化します。

Private Function BuildKey2(ByVal code As Variant, ByVal ymd As Variant) As String
    Dim ym As String
    If IsDate(ymd) Then ym = Format$(CDate(ymd), "yyyy-mm") Else ym = CStr(ymd)
    BuildKey2 = NormKey(code) & "|" & UCase$(Trim$(ym))
End Function

Sub Join_TwoStage_MultiKey()
    SpeedOn

    '明細: A=コード, B=年月(日付), C=数量
    '単価表: A=コード, B=年月, C=単価
    '税率表: A=年月, B=税率
    Dim vD As Variant: vD = Worksheets("明細").Range("A1").CurrentRegion.Value
    Dim vP As Variant: vP = Worksheets("単価表").Range("A1").CurrentRegion.Value
    Dim vT As Variant: vT = Worksheets("税率表").Range("A1").CurrentRegion.Value

    '辞書化
    Dim dictPrice As Object: Set dictPrice = CreateObject("Scripting.Dictionary")  ' key=コード|yyyy-mm → 単価
    Dim dictTax As Object:   Set dictTax   = CreateObject("Scripting.Dictionary")  ' key=yyyy-mm → 税率

    Dim i As Long, k As String, ym As String
    For i = 2 To UBound(vP, 1)
        ym = IIf(IsDate(vP(i, 2)), Format$(CDate(vP(i, 2)), "yyyy-mm"), CStr(vP(i, 2)))
        k = NormKey(vP(i, 1)) & "|" & UCase$(Trim$(ym))
        If Len(k) > 0 Then dictPrice(k) = CDbl(Val(vP(i, 3)))
    Next
    For i = 2 To UBound(vT, 1)
        ym = IIf(IsDate(vT(i, 1)), Format$(CDate(vT(i, 1)), "yyyy-mm"), CStr(vT(i, 1)))
        If Len(ym) > 0 Then dictTax(UCase$(Trim$(ym))) = CDbl(Val(vT(i, 2)))
    Next

    '出力
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 8)
    out(1, 1) = "コード": out(1, 2) = "年月": out(1, 3) = "数量": out(1, 4) = "単価": out(1, 5) = "税率"
    out(1, 6) = "金額(税抜)": out(1, 7) = "税込金額": out(1, 8) = "ステータス"

    Dim r As Long, key2 As String, ymD As String, qty As Double, st As String
    For r = 2 To UBound(vD, 1)
        ymD = IIf(IsDate(vD(r, 2)), Format$(CDate(vD(r, 2)), "yyyy-mm"), CStr(vD(r, 2)))
        key2 = NormKey(vD(r, 1)) & "|" & UCase$(Trim$(ymD))
        qty = CDbl(Val(vD(r, 3)))
        st = ""

        out(r, 1) = vD(r, 1)
        out(r, 2) = ymD
        out(r, 3) = qty

        Dim price As Double, tax As Double
        If dictPrice.Exists(key2) Then
            price = dictPrice(key2)
        Else
            price = 0: st = st & "単価未一致;"
        End If
        If dictTax.Exists(UCase$(Trim$(ymD))) Then
            tax = dictTax(UCase$(Trim$(ymD)))
        Else
            tax = 0: st = st & "税率未一致;"
        End If

        out(r, 4) = price
        out(r, 5) = tax
        out(r, 6) = price * qty
        out(r, 7) = price * qty * (1 + tax)
        out(r, 8) = IIf(st = "", "OK", st)
    Next

    With EnsureSheet("JOIN_2段_複合キー", True)
        .Range("A1").Resize(UBound(vD, 1), 8).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
        .Range("6:7").NumberFormat = "#,##0"
    End With

    SpeedOff
End Sub
VB
  • ポイント
    • 段1が複合キー（コード×年月）、段2は年月単独キー。
    • 表記を yyyy-mm で統一して比較ミス防止。

2段JOIN後に監査ログ（各段の未一致・重複）

段ごとの未一致キー、マスタ側の重複キーを一覧化。品質チェックに役立ちます。

Sub Join_TwoStage_Audit()
    '対象：上の Join_TwoStage_Left のマスタA/Bを流用するイメージ
    Dim vA As Variant: vA = Worksheets("マスタA").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("マスタB").Range("A1").CurrentRegion.Value
    Dim vD As Variant: vD = Worksheets("明細").Range("A1").CurrentRegion.Value

    Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary")
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim dupA As Object:  Set dupA  = CreateObject("Scripting.Dictionary")
    Dim dupB As Object:  Set dupB  = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String

    'A辞書＋重複
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, 1))
        If dictA.Exists(k) Then dupA(k) = True Else dictA(k) = True
    Next
    'B辞書＋重複
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, 1))
        If dictB.Exists(k) Then dupB(k) = True Else dictB(k) = True
    Next

    '明細の未一致（A, B）
    Dim missA As Object: Set missA = CreateObject("Scripting.Dictionary")
    Dim missB As Object: Set missB = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vD, 1)
        k = NormKey(vD(i, 1))
        If Len(k) > 0 Then
            If Not dictA.Exists(k) Then missA(k) = True
            If Not dictB.Exists(k) Then missB(k) = True
        End If
    Next

    Dim ws As Worksheet: Set ws = EnsureSheet("JOIN_監査", True)
    ws.Range("A1:D1").Value = Array("A未一致キー", "B未一致キー", "A重複キー", "B重複キー")
    Dim r1 As Long: r1 = 2: Dim x As Variant
    For Each x In missA.Keys: ws.Cells(r1, 1).Value = x: r1 = r1 + 1: Next
    Dim r2 As Long: r2 = 2
    For Each x In missB.Keys: ws.Cells(r2, 2).Value = x: r2 = r2 + 1: Next
    Dim r3 As Long: r3 = 2
    For Each x In dupA.Keys: ws.Cells(r3, 3).Value = x: r3 = r3 + 1: Next
    Dim r4 As Long: r4 = 2
    For Each x In dupB.Keys: ws.Cells(r4, 4).Value = x: r4 = r4 + 1: Next
    ws.Columns.AutoFit
End Sub
VB
  • ポイント
    • 段ごとの未一致・重複を分けて記録。修正指示が出しやすい。

よくある落とし穴と対策

  • キー表記揺れで段間の紐付けが崩れる
    • 対策: 両段で同じ正規化（Trim/UCase、必要なら半角化・記号除去）。
  • 段1で派生キーを作って段2に渡すときの型ズレ
    • 対策: 文字列として扱うルールを統一（CStr→Trim→UCase）。日付は yyyy-mm 固定。
  • 重複キーで上書き事故
    • 対策: 辞書化時に重複検出（dup辞書）→監査シートに出す。
  • 大量データで遅い
    • 対策: SpeedOn/Off＋配列/辞書＋一括貼付。段ごとに配列で処理し、セル往復をゼロに。

例題で練習

'例1：同一キーで A→B の2段左結合
Sub Example_TwoStageLeft()
    Join_TwoStage_Left
End Sub

'例2：キー連鎖（商品コード→分類コード→税率）
Sub Example_ChainedKeys()
    Join_TwoStage_ChainedKeys
End Sub

'例3：複合キー（コード×年月）→税率表の2段結合
Sub Example_TwoStageMultiKey()
    Join_TwoStage_MultiKey
End Sub

'例4：2段JOIN後の監査ログ（未一致・重複）
Sub Example_TwoStageAudit()
    Join_TwoStage_Audit
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました