Excel VBA 逆引き集 | 1対多JOINの展開

Excel VBA
スポンサーリンク

1対多JOINの展開

「顧客（1）→注文（多）」「商品（1）→出荷明細（多）」のように、キーで結びついた多明細を“横付け”や“縦に展開”したい場面のためのテンプレです。壊れないコツは「キーの正規化」「見出し名で列特定」「配列＋辞書（Collection）で格納」「新シートに一括出力」です。

どんな形に“展開”したいかを決める

  • 縦展開（標準）:
    親の属性を繰り返し、子明細を1行ずつ並べる（ピボット/集計に強い）。
  • 横展開（クロス・ワイド化）:
    子明細を列として並べる（子件数が少数固定のときのみ推奨）。
  • リスト化（文字結合）:
    子明細を1セルでカンマ連結（報告書・一覧向け）。

基本テンプレ：親1→子多を“縦に展開”して新シートへ

親（顧客）に子（注文）を結合し、親列を繰り返して子を1行ずつ出します。

Option Explicit

Private 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

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 Join_OneToMany_Vertical()
    '親: Sheet("顧客") A=顧客ID, B=顧客名, C=地区
    '子: Sheet("注文") A=顧客ID, B=注文日, C=数量, D=金額
    '出力: Sheet("1対多展開") … 顧客ID/顧客名/地区/注文日/数量/金額（縦展開）

    Dim wsP As Worksheet: Set wsP = Worksheets("顧客")
    Dim wsC As Worksheet: Set wsC = Worksheets("注文")
    Dim rgP As Range: Set rgP = wsP.Range("A1").CurrentRegion
    Dim rgC As Range: Set rgC = wsC.Range("A1").CurrentRegion
    Dim vP As Variant: vP = rgP.Value
    Dim vC As Variant: vC = rgC.Value

    '見出しを安全取得
    Dim cPid As Long: cPid = FindHeader(rgP.Rows(1), "顧客ID")
    Dim cPnm As Long: cPnm = FindHeader(rgP.Rows(1), "顧客名")
    Dim cParea As Long: cParea = FindHeader(rgP.Rows(1), "地区")
    Dim cCid As Long: cCid = FindHeader(rgC.Rows(1), "顧客ID")
    Dim cCdate As Long: cCdate = FindHeader(rgC.Rows(1), "注文日")
    Dim cCqty As Long: cCqty = FindHeader(rgC.Rows(1), "数量")
    Dim cCamt As Long: cCamt = FindHeader(rgC.Rows(1), "金額")
    If cPid * cPnm * cParea * cCid * cCdate * cCqty * cCamt = 0 Then
        MsgBox "見出し不足（顧客ID/顧客名/地区/注文日/数量/金額）": Exit Sub
    End If

    '子を辞書（顧客ID→Collection(子行インデックス)）に格納
    Dim childs As Object: Set childs = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vC, 1)
        k = UCase$(Trim$(CStr(vC(i, cCid))))
        If Len(k) > 0 Then
            If Not childs.Exists(k) Then Set childs(k) = New Collection
            childs(k).Add i
        End If
    Next

    '出力配列：親×子の直積行数を見積もって作成
    Dim totalRows As Long: totalRows = 1 'ヘッダー分
    Dim r As Long
    For r = 2 To UBound(vP, 1)
        k = UCase$(Trim$(CStr(vP(r, cPid))))
        If Len(k) > 0 And childs.Exists(k) Then
            totalRows = totalRows + childs(k).Count
        Else
            '子がない親も出す場合は +1（必要なら）
            totalRows = totalRows + 1
        End If
    Next

    Dim out() As Variant: ReDim out(1 To totalRows, 1 To 6)
    out(1, 1) = "顧客ID": out(1, 2) = "顧客名": out(1, 3) = "地区": out(1, 4) = "注文日": out(1, 5) = "数量": out(1, 6) = "金額"

    Dim w As Long: w = 2
    For r = 2 To UBound(vP, 1)
        k = UCase$(Trim$(CStr(vP(r, cPid))))
        Dim pid As Variant: pid = vP(r, cPid)
        Dim pnm As Variant: pnm = vP(r, cPnm)
        Dim parea As Variant: parea = vP(r, cParea)

        If Len(k) > 0 And childs.Exists(k) Then
            Dim idx As Variant
            For Each idx In childs(k)
                out(w, 1) = pid
                out(w, 2) = pnm
                out(w, 3) = parea
                out(w, 4) = vC(idx, cCdate)
                out(w, 5) = CDbl(Val(vC(idx, cCqty)))
                out(w, 6) = CDbl(Val(vC(idx, cCamt)))
                w = w + 1
            Next
        Else
            '子なし親を表示したい場合（コメント解除）
            'out(w, 1) = pid: out(w, 2) = pnm: out(w, 3) = parea
            'out(w, 4) = "": out(w, 5) = 0: out(w, 6) = 0
            'w = w + 1
        End If
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("1対多展開", True)
    wsOut.Range("A1").Resize(w - 1, 6).Value = out
    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit
    wsOut.Range("E2:E" & w - 1).NumberFormat = "0"
    wsOut.Range("F2:F" & w - 1).NumberFormat = "#,##0"
End Sub
VB
  • ポイント
    • 親属性の繰り返し: 子行ごとに親列を重ねて縦展開。
    • 子なし親の扱い: 出すかどうかはコメント解除で選べる。
    • 辞書＋Collection: 1キーに複数行を付ける構造が安定・高速。

子を“横に並べる”ワイド展開（最大子件数が少ない場合のみ）

子の件数が少数（例：最大3件）で、列として横展開したいときのテンプレです。

Sub Join_OneToMany_Wide()
    '親: 顧客（ID/名/地区）
    '子: 注文（ID/日付/金額）
    '出力: 顧客ごとに「注文日1/金額1」「注文日2/金額2」…を横展開

    Dim vP As Variant: vP = Worksheets("顧客").Range("A1").CurrentRegion.Value
    Dim vC As Variant: vC = Worksheets("注文").Range("A1").CurrentRegion.Value

    '見出し列（簡略：固定位置想定、必要ならFindHeaderに置き換え）
    Dim cPidP As Long: cPidP = 1
    Dim cPnm As Long: cPnm = 2
    Dim cParea As Long: cParea = 3
    Dim cPidC As Long: cPidC = 1
    Dim cDateC As Long: cDateC = 2
    Dim cAmtC As Long: cAmtC = 4 '例：金額がD列

    '顧客→子配列の辞書（最大3件まで取り込む例）
    Dim children As Object: Set children = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vC, 1)
        k = UCase$(Trim$(CStr(vC(i, cPidC))))
        If Len(k) = 0 Then GoTo contC
        If Not children.Exists(k) Then children(k) = Array("", 0#, "", 0#, "", 0#)
        Dim arr As Variant: arr = children(k)
        '空きスロットに詰める（最大3件）
        Dim slot As Long
        For slot = 0 To 2
            If arr(slot * 2) = "" Then
                arr(slot * 2) = vC(i, cDateC)
                arr(slot * 2 + 1) = CDbl(Val(vC(i, cAmtC)))
                Exit For
            End If
        Next
        children(k) = arr
contC:
    Next

    '出力（親1行につき固定列）
    Dim out() As Variant: ReDim out(1 To UBound(vP, 1), 1 To 9)
    out(1, 1) = "顧客ID": out(1, 2) = "顧客名": out(1, 3) = "地区"
    out(1, 4) = "注文日1": out(1, 5) = "金額1"
    out(1, 6) = "注文日2": out(1, 7) = "金額2"
    out(1, 8) = "注文日3": out(1, 9) = "金額3"

    Dim r As Long
    For r = 2 To UBound(vP, 1)
        k = UCase$(Trim$(CStr(vP(r, cPidP))))
        out(r, 1) = vP(r, cPidP)
        out(r, 2) = vP(r, cPnm)
        out(r, 3) = vP(r, cParea)
        If children.Exists(k) Then
            Dim a As Variant: a = children(k)
            out(r, 4) = a(0): out(r, 5) = a(1)
            out(r, 6) = a(2): out(r, 7) = a(3)
            out(r, 8) = a(4): out(r, 9) = a(5)
        End If
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("1対多ワイド", True)
    wsOut.Range("A1").Resize(UBound(vP, 1), 9).Value = out
    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • ワイド化の限界: 子列の最大数が決まっているときのみ現実的。
    • 空スロット: 子が少ない場合は空欄のままでもOK。

子を“1セルにリスト化”して横付け（文字結合）

親ごとに子の項目を「カンマ区切り」などで1セルにまとめます。

Sub Join_OneToMany_Concatenate()
    '親: 顧客（ID/名）
    '子: 注文（ID/商品名）
    '出力: 顧客ごとに「商品名一覧」を1セルに結合

    Dim vP As Variant: vP = Worksheets("顧客").Range("A1").CurrentRegion.Value
    Dim vC As Variant: vC = Worksheets("注文").Range("A1").CurrentRegion.Value

    '顧客IDの子商品名コレクション
    Dim items As Object: Set items = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vC, 1)
        k = UCase$(Trim$(CStr(vC(i, 1)))) '子の顧客ID
        If Len(k) > 0 Then
            If Not items.Exists(k) Then Set items(k) = New Collection
            items(k).Add CStr(vC(i, 2))     '商品名（例：B列）
        End If
    Next

    '出力
    Dim out() As Variant: ReDim out(1 To UBound(vP, 1), 1 To 3)
    out(1, 1) = "顧客ID": out(1, 2) = "顧客名": out(1, 3) = "商品名一覧"

    Dim r As Long
    For r = 2 To UBound(vP, 1)
        k = UCase$(Trim$(CStr(vP(r, 1))))
        out(r, 1) = vP(r, 1)
        out(r, 2) = vP(r, 2)
        If items.Exists(k) Then
            'Collection→配列化してJoin
            Dim col As Collection: Set col = items(k)
            Dim arr() As String: ReDim arr(0 To col.Count - 1)
            Dim j As Long
            For j = 1 To col.Count: arr(j - 1) = col(j): Next
            out(r, 3) = Join(arr, ", ")
        Else
            out(r, 3) = ""
        End If
    Next

    With EnsureSheet("1対多_文字結合", True)
        .Range("A1").Resize(UBound(vP, 1), 3).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • Joinで結合: 文字配列を区切りで連結。長い一覧は改行 vbLf も使える。
    • ユースケース: レポートやメール貼り付けに便利。

実務の落とし穴と対策

  • キーの表記揺れで紐付かない
    • 対策: 正規化必須。 Trim/UCase に加え、必要なら半角化・不要記号除去を入れる。
  • 見出しや列順が変わって壊れる
    • 対策: FindHeaderで列特定。 ハードコード禁止、早期検知メッセージ。
  • 子が極端に多い（数千件/親）
    • 対策: 縦展開で出力。ワイド化や文字結合はサイズが膨らみ可読性が落ちる。
  • 速度が出ない
    • 対策: 配列→辞書→一括貼付。 前後で ScreenUpdating=False・Calculation=Manual を使うと安定。
  • 重複や並びが気になる
    • 対策: 子をソートしてから結合（Collectionではなく一時配列を並べ替え）、または出力後に Range.Sort。

例題で練習

'例1：親×子を縦に展開して新シートへ
Sub Example_Vertical()
    Join_OneToMany_Vertical
End Sub

'例2：子を横展開（最大3件）してレポート用に
Sub Example_Wide()
    Join_OneToMany_Wide
End Sub

'例3：子をカンマ連結して一覧化
Sub Example_Concatenate()
    Join_OneToMany_Concatenate
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました