Excel VBA 逆引き集 | クロス集計

Excel VBA
スポンサーリンク

クロス集計

「行＝カテゴリ」「列＝カテゴリ」で値を並べるクロス集計は、ピボットが最短。見出しや書式を作り込みたいなら SUMIFS で行・列ループ、爆速・柔軟なら辞書で2軸集計して表を生成します。初心者でも壊れないテンプレを揃えました。

選び方の指針

  • 最短・見た目重視: ピボットテーブル（行×列×値）
  • 決め打ちの行・列ラベルに出したい: SUMIFSで行・列を回してセルに出力
  • 大量・柔軟（部分一致、整形、ゼロ補完）: 辞書で2軸キー集計→配列で表を作成
  • 列順が変わる現場: 見出し名から列番号を取得して安全に参照

ピボットで一発クロス（最短）

Sub Cross_Pivot()
    '明細：A=行側（例：部署）、B=列側（例：商品）、C=値（例：金額）
    Dim src As Range: Set src = Range("A1").CurrentRegion

    '出力シート用意
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("クロスPT")
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add: outWs.Name = "クロスPT"
    End If
    On Error GoTo 0

    'ピボット生成
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, src)
    Set pt = pc.CreatePivotTable(outWs.Range("A3"), "クロス集計PT")

    With pt
        .PivotFields("部署").Orientation = xlRowField          '行
        .PivotFields("商品").Orientation = xlColumnField       '列
        With .PivotFields("金額")                               '値
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
        End With
    End With
End Sub
VB
  • ポイント
    • 見た目が強い: 並べ替え・小計・総計もボタン操作で。
    • 更新は一行: pt.PivotCache.Refresh。元データをテーブル化すると範囲拡張も自動。

SUMIFSで行×列ループのクロス集計（決め打ちラベルに強い）

Sub Cross_SumIfs()
    '明細：A=行キー（部署）、B=列キー（商品）、C=値（金額）
    Dim rowKeyR As Range: Set rowKeyR = Range("A2:A100000")
    Dim colKeyR As Range: Set colKeyR = Range("B2:B100000")
    Dim valR    As Range: Set valR    = Range("C2:C100000")

    '出力側：F列に行ラベル（部署）、G1以降に列ラベル（商品）
    Dim lastRow As Long: lastRow = Cells(Rows.Count, "F").End(xlUp).Row
    Dim lastCol As Long: lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

    Dim r As Long, c As Long
    For r = 2 To lastRow
        For c = 7 To lastCol             'G=7列
            Cells(r, c).Value = Application.WorksheetFunction.SumIfs( _
                valR, rowKeyR, Cells(r, "F").Value, colKeyR, Cells(1, c).Value)
        Next
    Next

    '書式
    Range(Cells(2, 7), Cells(lastRow, lastCol)).NumberFormat = "#,##0"
End Sub
VB
  • ポイント
    • 行・列の並びを固定したいときに最適（報告書フォーマットに合わせやすい）。
    • ゼロ補完も簡単: 結果が空なら0代入などの処理を足せる。

辞書で2軸キーを爆速クロス（ユニーク抽出→表生成）

Sub Cross_Dictionary()
    '明細：A=行キー（部署）、B=列キー（商品）、C=値（合計対象）
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    'ユニーク行・列ラベル収集
    Dim rows As Object: Set rows = CreateObject("Scripting.Dictionary")
    Dim cols As Object: Set cols = CreateObject("Scripting.Dictionary")

    '2軸キーの合計
    Dim m As Object: Set m = CreateObject("Scripting.Dictionary") 'key="row|col" → sum
    Dim i As Long, rKey As String, cKey As String, key As String, val As Double
    For i = 2 To UBound(v, 1)
        rKey = Trim$(CStr(v(i, 1)))
        cKey = Trim$(CStr(v(i, 2)))
        val = Val(v(i, 3))
        If Len(rKey) > 0 And Len(cKey) > 0 Then
            rows(rKey) = True: cols(cKey) = True
            key = rKey & "|" & cKey
            If m.Exists(key) Then m(key) = m(key) + val Else m.Add key, val
        End If
    Next

    '出力配列組み立て（行数＝ユニーク行＋ヘッダー、列数＝ユニーク列＋行ラベル列）
    Dim rKeys As Variant: rKeys = rows.Keys
    Dim cKeys As Variant: cKeys = cols.Keys
    Dim rN As Long: rN = UBound(rKeys) + 1
    Dim cN As Long: cN = UBound(cKeys) + 1

    Dim out() As Variant: ReDim out(1 To rN + 1, 1 To cN + 1)

    'ヘッダー
    out(1, 1) = "行"
    Dim j As Long
    For j = 0 To UBound(cKeys)
        out(1, j + 2) = cKeys(j)
    Next

    'データ
    Dim iRow As Long, iCol As Long
    For iRow = 0 To UBound(rKeys)
        out(iRow + 2, 1) = rKeys(iRow)
        For iCol = 0 To UBound(cKeys)
            key = rKeys(iRow) & "|" & cKeys(iCol)
            out(iRow + 2, iCol + 2) = IIf(m.Exists(key), m(key), 0)
        Next
    Next

    'シートへ出力
    With Worksheets("クロス")
        .Cells.Clear
        .Range("A1").Resize(rN + 1, cN + 1).Value = out
        .Range(.Cells(2, 2), .Cells(rN + 1, cN + 1)).NumberFormat = "#,##0"
        .Rows(1).Font.Bold = True
        .Columns(1).Font.Bold = True
    End With
End Sub
VB
  • ポイント
    • ユニーク行・列を自動抽出してゼロ補完。ラベルが増減しても壊れない。
    • 高速: 10万行規模でも配列＋辞書で現実的な速度。
    • 柔軟: 部分一致や前処理（正規化）を好きに入れられる。

列名から安全に参照（列順変更に強い）

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
VB
  • 使い方の例
    • ラベル: 行キー・列キー・値の列を見出し名で特定してから、上記テンプレに渡す。
    • メリット: 列順入れ替えや列追加に耐性が出る。

総計・書式・ゼロ補完の仕上げ

  • 行合計・列合計を出す:
    • 行は各行の右端に WorksheetFunction.Sum、列は最下行に一括 SUM を入れて値化。
  • ゼロの見やすさ:
    • 0 表示をダッシュにしたいなら、表示形式を #,##0;-#,##0;"-" に。
  • 幅自動調整・見た目:
    • 出力後に Columns.AutoFit、ヘッダー行・行ラベルに太字を当てる。
  • 昇順で並べたい:
    • rKeys/cKeys をソートしてから配列化（簡易なら WorksheetFunction.Sort を使わず、配列ソート実装かピボットの並べ替えで）。

よくある落とし穴と対策

  • ラベルの表記揺れで別列になる
    • 対策: 事前に Trim・大文字化・半角化で正規化。不要記号は Replace。
  • 数値が文字列で合計できない
    • 対策: Val で安全に数値化、式が入っているなら .Value = .Value で値化。
  • 行・列ラベルの固定が必要
    • 対策: SUMIFS方式で固定ラベルを配置。辞書方式なら不足は0補完。
  • セル往復で遅い
    • 対策: 範囲→配列→辞書→配列の一括貼付にする。書式は最後にまとめて。

例題で練習

'例1：ピボットで「部署×商品×金額合計」のクロスを一発
Sub Example_CrossPivot()
    Call Cross_Pivot
End Sub

'例2：F列の部署、1行目の商品ラベルに合わせてSUMIFSでクロス
Sub Example_CrossSumIfs()
    Call Cross_SumIfs
End Sub

'例3：辞書でユニーク行・列を抽出しゼロ補完付きクロス表を作成
Sub Example_CrossDict()
    Call Cross_Dictionary
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました