Excel VBA 逆引き集 | JOIN 高速テンプレ（配列版）

Excel VBA
スポンサーリンク

JOIN 高速テンプレ（配列版）

「辞書なし」で速く安定してJOINしたいときの配列テンプレです。ポイントは「範囲→配列」「キーを正規化」「Match（線形）か二分探索（高速）で突き合わせ」「一括貼り付け」。初心者でも貼って動くように、左結合・内結合・見出し対応・二分探索版までまとめました。

高速化の基本ユーティリティ

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で表記揺れを吸収。

左結合（配列＋Match版）：最短で速い

Application.Matchでマスタ配列のキー列を探す「VLOOKUP相当」の左結合です。

Sub Join_Left_ArrayMatch()
    SpeedOn

    '明細: Sheet("明細") … コード/数量
    'マスタ: Sheet("マスタ") … コード/名称/単価
    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").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 SpeedOff: MsgBox "見出し不足": Exit Sub

    'マスタキー列を一次元配列に
    Dim mKeys() As String
    Dim i As Long
    ReDim mKeys(1 To UBound(vM, 1) - 1)
    For i = 2 To UBound(vM, 1)
        mKeys(i - 1) = NormKey(vM(i, cKeyM))
    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, pos As Variant
    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)))
        out(r, 1) = vD(r, cKeyD)
        out(r, 4) = qty

        'Matchは1基準。mKeysは見出しを除いた1..nで作成済み
        pos = Application.Match(kd, mKeys, 0)
        If IsError(pos) Then
            out(r, 2) = "#N/A": out(r, 3) = 0: out(r, 5) = 0
        Else
            Dim mRow As Long: mRow = pos + 1 '見出し除去分の補正
            out(r, 2) = vM(mRow + 1, cNameM)
            out(r, 3) = CDbl(Val(vM(mRow + 1, cPriceM)))
            out(r, 5) = out(r, 3) * qty
        End If
    Next

    With EnsureSheet("LEFT_JOIN_Array", 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
  • ポイント
    • VLOOKUP相当: Matchで行位置を掴み、配列から値を引く。
    • 数値化: Val→CDblで文字数値のズレを防ぐ。

内結合（配列＋Match版）：一致のみ出力

未一致行を捨てたいときの最短テンプレです。

Sub Join_Inner_ArrayMatch()
    SpeedOn

    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").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 SpeedOff: MsgBox "見出し不足": Exit Sub

    Dim mKeys() As String, i As Long
    ReDim mKeys(1 To UBound(vM, 1) - 1)
    For i = 2 To UBound(vM, 1): mKeys(i - 1) = NormKey(vM(i, cKeyM)): Next

    '件数見積もり
    Dim cnt As Long: cnt = 1
    Dim r As Long, pos As Variant
    For r = 2 To UBound(vD, 1)
        pos = Application.Match(NormKey(vD(r, cKeyD)), mKeys, 0)
        If Not IsError(pos) Then cnt = cnt + 1
    Next

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

    Dim w As Long: w = 2
    For r = 2 To UBound(vD, 1)
        pos = Application.Match(NormKey(vD(r, cKeyD)), mKeys, 0)
        If Not IsError(pos) Then
            Dim mRow As Long: mRow = pos + 1
            Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
            out(w, 1) = vD(r, cKeyD)
            out(w, 2) = vM(mRow + 1, cNameM)
            out(w, 3) = CDbl(Val(vM(mRow + 1, cPriceM)))
            out(w, 4) = qty
            out(w, 5) = out(w, 3) * qty
            w = w + 1
        End If
    Next

    With EnsureSheet("INNER_JOIN_Array", True)
        .Range("A1").Resize(cnt, 5).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With

    SpeedOff
End Sub
VB
  • ポイント
    • 見積もり→確保: ReDimを最小化して速い。
    • 未一致は出さない: 抽出やレポートに最適。

二分探索（配列版最速）：マスタ配列をインデックスソートして検索

大量行でさらに速くしたいときは「インデックス配列をソート→二分探索」が効きます。

'キー文字列比較で idx() をクイックソート
Private Sub QuickSortByKey(ByRef idx() As Long, ByRef vM As Variant, ByVal cKey As Long, ByVal lo As Long, ByVal hi As Long)
    Dim i As Long, j As Long, pivot As String, tmp As Long
    i = lo: j = hi
    pivot = NormKey(vM(idx((lo + hi) \ 2), cKey))
    Do While i <= j
        Do While StrComp(NormKey(vM(idx(i), cKey)), pivot, vbTextCompare) < 0: i = i + 1: Loop
        Do While StrComp(NormKey(vM(idx(j), cKey)), pivot, vbTextCompare) > 0: j = j - 1: Loop
        If i <= j Then
            tmp = idx(i): idx(i) = idx(j): idx(j) = tmp
            i = i + 1: j = j - 1
        End If
    Loop
    If lo < j Then QuickSortByKey idx, vM, cKey, lo, j
    If i < hi Then QuickSortByKey idx, vM, cKey, i, hi
End Sub

'二分探索でキーの行インデックス（vMの行番号）を返す。見つからないときは0
Private Function BinaryFindRow(ByRef idx() As Long, ByRef vM As Variant, ByVal cKey As Long, ByVal key As String) As Long
    Dim lo As Long, hi As Long, mid As Long, cmp As Long
    lo = LBound(idx): hi = UBound(idx)
    Do While lo <= hi
        mid = (lo + hi) \ 2
        cmp = StrComp(NormKey(vM(idx(mid), cKey)), key, vbTextCompare)
        If cmp = 0 Then BinaryFindRow = idx(mid): Exit Function
        If cmp < 0 Then lo = mid + 1 Else hi = mid - 1
    Loop
    BinaryFindRow = 0
End Function

Sub Join_Left_ArrayBinary()
    SpeedOn

    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").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 SpeedOff: MsgBox "見出し不足": Exit Sub

    'マスタ行インデックス（見出し除く 2..n）
    Dim nM As Long: nM = UBound(vM, 1)
    Dim idx() As Long: ReDim idx(1 To nM - 1)
    Dim i As Long
    For i = 1 To nM - 1: idx(i) = i + 1: Next

    'インデックスをキーでクイックソート
    QuickSortByKey idx, vM, cKeyM, LBound(idx), UBound(idx)

    '出力配列
    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, mRow 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)))
        out(r, 1) = vD(r, cKeyD)
        out(r, 4) = qty

        mRow = BinaryFindRow(idx, vM, cKeyM, kd)
        If mRow = 0 Then
            out(r, 2) = "#N/A": out(r, 3) = 0: out(r, 5) = 0
        Else
            out(r, 2) = vM(mRow, cNameM)
            out(r, 3) = CDbl(Val(vM(mRow, cPriceM)))
            out(r, 5) = out(r, 3) * qty
        End If
    Next

    With EnsureSheet("LEFT_JOIN_ArrayBinary", 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
  • ポイント
    • 指数関数的に速い: 線形探索をやめて二分探索へ。
    • 安全: 元配列を直接並べ替えず、インデックス配列だけをソート。

複数キー対応（コード×年月を配列でJOIN）

複合キーは「連結した文字列キー」を作り、同じやり方でMatch/二分探索します。

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_Left_Array_MultiKey()
    SpeedOn

    '明細: A=コード, B=日付/年月, C=数量
    'マスタ: A=コード, B=名称, C=単価
    Dim vD As Variant: vD = Worksheets("明細").Range("A1").CurrentRegion.Value
    Dim vM As Variant: vM = Worksheets("マスタ").Range("A1").CurrentRegion.Value

    Dim cCodeD As Long: cCodeD = 1
    Dim cYmD   As Long: cYmD   = 2
    Dim cQtyD  As Long: cQtyD  = 3
    Dim cCodeM As Long: cCodeM = 1
    Dim cNameM As Long: cNameM = 2
    Dim cPriceM As Long: cPriceM = 3

    'マスタはコード単価のため、JOINは「コード一致＋年月は明細側だけ使う」構成
    Dim mKeys() As String, i As Long
    ReDim mKeys(1 To UBound(vM, 1) - 1)
    For i = 2 To UBound(vM, 1)
        mKeys(i - 1) = NormKey(vM(i, cCodeM))
    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, pos As Variant
    For r = 2 To UBound(vD, 1)
        Dim key2 As String: key2 = BuildKey2(vD(r, cCodeD), vD(r, cYmD))
        Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
        out(r, 1) = vD(r, cCodeD)
        out(r, 4) = IIf(IsDate(vD(r, cYmD)), Format$(CDate(vD(r, cYmD)), "yyyy-mm"), CStr(vD(r, cYmD)))
        out(r, 5) = qty
        out(r, 7) = key2

        pos = Application.Match(NormKey(vD(r, cCodeD)), mKeys, 0)
        If IsError(pos) Then
            out(r, 2) = "#N/A": out(r, 3) = 0: out(r, 6) = 0
        Else
            Dim mRow As Long: mRow = pos + 1
            out(r, 2) = vM(mRow + 1, cNameM)
            out(r, 3) = CDbl(Val(vM(mRow + 1, cPriceM)))
            out(r, 6) = out(r, 3) * qty
        End If
    Next

    With EnsureSheet("LEFT_JOIN_Array_MultiKey", 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
  • ポイント
    • 複合キーは文字連結: 区切りは「|」など安全な記号。
    • 年月統一: yyyy-mmに固定で表記揺れを防ぐ。

実務の落とし穴と対策

  • キー表記揺れで一致しない
    • 対策: NormKey（Trim＋UCase）を両側に徹底。必要なら半角化・記号除去も追加。
  • 数値が文字列で計算ミス
    • 対策: Val→CDblで数値化してから計算する。書式は出力後に整える。
  • 列順変更で壊れる
    • 対策: FindHeaderで列を特定。ハードコードを避ける。
  • 大量行で遅い
    • 対策: Match版より二分探索（インデックス＋クイックソート）に切り替える。

例題で練習

'例1：配列＋Matchで左結合
Sub Example_Left_Array()
    Join_Left_ArrayMatch
End Sub

'例2：配列＋Matchで内結合（一致のみ）
Sub Example_Inner_Array()
    Join_Inner_ArrayMatch
End Sub

'例3：インデックスソート＋二分探索で超高速左結合
Sub Example_Left_ArrayBinary()
    Join_Left_ArrayBinary
End Sub

'例4：複合キー（コード×年月）を配列でJOIN
Sub Example_Left_ArrayMultiKey()
    Join_Left_Array_MultiKey
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました