Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – 売上集計＋明細整形

Excel VBA
スポンサーリンク

ねらい：売上明細を“整形→集計→見える化”まで一括で回す

売上管理の現場で本当に効くのは「明細の欠損や型ブレを直す→キーを正規化する→集計してアウトプットを整える」という一本の流れです。Excel関数の貼り付けや手作業は規模が増えるほど壊れますが、VBAなら“配列I/O＋Dictionary＋正規化＋一括書き戻し”の型で、十万行でも一瞬で安定します。初心者でも貼って動くテンプレを、明細整形・月次／顧客別集計・クロス表・ランキング・出力整形まで、例題付きでかみ砕いて説明します。

共通基盤：配列I/O・正規化・数値／日付の安全変換

一括読み書きと正規化ユーティリティ

' ModSales_Base.bas
Option Explicit
Private Const SEP As String = Chr$(30)

Public Function ReadRegion(ByVal ws As Worksheet, Optional ByVal topLeft As String = "A1") As Variant
    ReadRegion = ws.Range(topLeft).CurrentRegion.Value
End Function

Public Sub WriteBlock(ByVal ws As Worksheet, ByVal a As Variant, ByVal topLeft As String)
    ws.Range(topLeft).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Public Function NormKey(ByVal v As Variant) As String
    NormKey = LCase$(Trim$(CStr(v))) ' 大小無視・前後空白除去
End Function

Public Function ToNumberOrZero(ByVal v As Variant) As Double
    If IsNumeric(v) Then
        ToNumberOrZero = CDbl(v)
    Else
        ToNumberOrZero = 0#
    End If
End Function

Public Function ToDateOrEmpty(ByVal v As Variant) As Variant
    If IsDate(v) Then
        ToDateOrEmpty = CDate(v)
    Else
        ToDateOrEmpty = ""
    End If
End Function

Public Sub ApplyOutputFormat(ByVal ws As Worksheet, ByVal rangeAddress As String, _
                             Optional ByVal currencyCols As String = "", _
                             Optional ByVal dateCols As String = "", _
                             Optional ByVal thousandSep As Boolean = True)
    Dim rng As Range: Set rng = ws.Range(rangeAddress).CurrentRegion
    rng.Columns.AutoFit
    rng.Borders.LineStyle = xlContinuous
    If thousandSep And Len(currencyCols) > 0 Then
        Dim cols() As String: cols = Split(currencyCols, ",")
        Dim i As Long
        For i = LBound(cols) To UBound(cols)
            ws.Columns(Trim$(cols(i))).NumberFormatLocal = "#,##0"
        Next
    End If
    If Len(dateCols) > 0 Then
        Dim d() As String: d = Split(dateCols, ",")
        Dim j As Long
        For j = LBound(d) To UBound(d)
            ws.Columns(Trim$(d(j))).NumberFormatLocal = "yyyy-mm-dd"
        Next
    End If
End Sub
VB

重要ポイントの深掘り

明細の型ブレ（文字数値、テキスト日付）を必ず入口で直します。数値は CDbl、日付は CDate、ダメなら安全な既定値（0や空）へ落とす方針を最初に決めると、後段の集計が壊れません。キーは NormKey で揺らぎを除去し、重複やヒット漏れを根絶します。

明細整形：入力ゆれの矯正と派生列の付与

売上明細のクリーニングと派生列（年月・単価）

' ModSales_Clean.bas
Option Explicit

' Data: A=注文日, B=顧客ID, C=商品ID, D=数量, E=金額（総額）
' 出力（同じシートの指定位置へ上書き）: 年月、正規化キー、単価を付与
Public Sub CleanSalesDetail(ByVal sheetName As String, ByVal outStart As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    ' 新しい出力配列（元＋派生3列：YearMonth, CustKey, UnitPrice）
    Dim out() As Variant: ReDim out(1 To UBound(a, 1), 1 To UBound(a, 2) + 3)

    ' ヘッダコピー＋追加
    Dim c As Long
    For c = 1 To UBound(a, 2): out(1, c) = a(1, c): Next
    out(1, UBound(a, 2) + 1) = "YearMonth"
    out(1, UBound(a, 2) + 2) = "CustKey"
    out(1, UBound(a, 2) + 3) = "UnitPrice"

    ' データ整形
    Dim r As Long
    For r = 2 To UBound(a, 1)
        ' 原本コピー
        For c = 1 To UBound(a, 2): out(r, c) = a(r, c): Next

        ' 日付→年月キー
        Dim dt As Variant: dt = ToDateOrEmpty(a(r, 1))
        out(r, UBound(a, 2) + 1) = IIf(IsDate(dt), Format(CDate(dt), "yyyy-mm"), "")

        ' 顧客キー正規化
        out(r, UBound(a, 2) + 2) = NormKey(a(r, 2))

        ' 単価（総額/数量、ゼロ割回避）
        Dim qty As Double: qty = ToNumberOrZero(a(r, 4))
        Dim amt As Double: amt = ToNumberOrZero(a(r, 5))
        out(r, UBound(a, 2) + 3) = IIf(qty > 0, amt / qty, 0#)
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, "E," & ColLetter(UBound(a, 2) + 3), "A"
End Sub

Private Function ColLetter(ByVal colIndex As Long) As String
    ColLetter = Split(Cells(1, colIndex).Address(True, False), "$")(0)
End Function
VB

重要ポイントの深掘り

現場の事故は「文字の日付」「数量ゼロ」「顧客IDの前後空白」といった入力ゆれです。最初に一本で整え、「年月」「正規化キー」「単価」を派生しておくと、その後の集計ロジックがシンプルになり、壊れません。ゼロ割は必ず回避し、単価は0に落としておくのが定番です。

売上集計：顧客別・月別・商品別の合計／件数／平均

顧客別の合計・件数・平均を一撃で

' ModSales_AggCustomer.bas
Option Explicit

' A=注文日, B=顧客ID, D=数量, E=金額（総額）
Public Sub AggregateByCustomer(ByVal sheetName As String, ByVal outStart As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    Dim sumAmt As Object: Set sumAmt = CreateObject("Scripting.Dictionary"): sumAmt.CompareMode = 1
    Dim sumQty As Object: Set sumQty = CreateObject("Scripting.Dictionary"): sumQty.CompareMode = 1
    Dim cnt As Object: Set cnt = CreateObject("Scripting.Dictionary"): cnt.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim cust As String: cust = NormKey(a(r, 2))
        Dim amt As Double: amt = ToNumberOrZero(a(r, 5))
        Dim qty As Double: qty = ToNumberOrZero(a(r, 4))

        sumAmt(cust) = IIf(sumAmt.Exists(cust), sumAmt(cust) + amt, amt)
        sumQty(cust) = IIf(sumQty.Exists(cust), sumQty(cust) + qty, qty)
        cnt(cust) = IIf(cnt.Exists(cust), cnt(cust) + 1, 1)
    Next

    Dim out() As Variant: ReDim out(1 To sumAmt.Count + 1, 1 To 5)
    out(1, 1) = "CustomerKey": out(1, 2) = "SumAmount": out(1, 3) = "SumQty": out(1, 4) = "Count": out(1, 5) = "AvgAmountPerOrder"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In sumAmt.Keys
        out(i, 1) = k
        out(i, 2) = sumAmt(k)
        out(i, 3) = sumQty(k)
        out(i, 4) = cnt(k)
        out(i, 5) = IIf(cnt(k) > 0, sumAmt(k) / cnt(k), 0#)
        i = i + 1
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, ColLetter(2), ""
End Sub
VB

月次合計（売上の推移）

' ModSales_AggMonthly.bas
Option Explicit

' A=注文日, E=金額
Public Sub AggregateMonthly(ByVal sheetName As String, ByVal outStart As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    Dim sumMon As Object: Set sumMon = CreateObject("Scripting.Dictionary"): sumMon.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim dt As Variant: dt = ToDateOrEmpty(a(r, 1))
        If IsDate(dt) Then
            Dim monKey As String: monKey = Format(CDate(dt), "yyyy-mm")
            Dim amt As Double: amt = ToNumberOrZero(a(r, 5))
            sumMon(monKey) = IIf(sumMon.Exists(monKey), sumMon(monKey) + amt, amt)
        End If
    Next

    Dim out() As Variant: ReDim out(1 To sumMon.Count + 1, 1 To 2)
    out(1, 1) = "Month": out(1, 2) = "SumAmount"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In sumMon.Keys
        out(i, 1) = k
        out(i, 2) = sumMon(k)
        i = i + 1
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, ColLetter(2), ""
End Sub
VB

商品別ランキング（トップN）

' ModSales_TopProducts.bas
Option Explicit

' C=商品ID, E=金額
Public Sub TopNProducts(ByVal sheetName As String, ByVal outStart As String, ByVal topN As Long)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    Dim sumProd As Object: Set sumProd = CreateObject("Scripting.Dictionary"): sumProd.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim pid As String: pid = NormKey(a(r, 3))
        Dim amt As Double: amt = ToNumberOrZero(a(r, 5))
        sumProd(pid) = IIf(sumProd.Exists(pid), sumProd(pid) + amt, amt)
    Next

    Dim rows As Long: rows = sumProd.Count
    Dim t() As Variant: ReDim t(1 To rows, 1 To 2)
    Dim i As Long: i = 1
    Dim k As Variant
    For Each k In sumProd.Keys
        t(i, 1) = k: t(i, 2) = sumProd(k)
        i = i + 1
    Next

    Call Sort2DByColDesc(t, 2)

    Dim out() As Variant: ReDim out(1 To WorksheetFunction.Min(topN + 1, rows + 1), 1 To 2)
    out(1, 1) = "ProductKey": out(1, 2) = "SumAmount"
    For i = 2 To UBound(out, 1)
        out(i, 1) = t(i - 1, 1)
        out(i, 2) = t(i - 1, 2)
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, ColLetter(2), ""
End Sub

Private Sub Sort2DByColDesc(ByRef a As Variant, ByVal col As Long)
    Dim n As Long: n = UBound(a, 1)
    Dim i As Long, j As Long, k As Long, tmp As Variant
    For i = 1 To n - 1
        For j = i + 1 To n
            If CDbl(a(i, col)) < CDbl(a(j, col)) Then
                For k = 1 To UBound(a, 2)
                    tmp = a(i, k): a(i, k) = a(j, k): a(j, k) = tmp
                Next
            End If
        Next
    Next
End Sub
VB

重要ポイントの深掘り

集計は「キー正規化→数値化→辞書に蓄積→最後に配列で出す」の一本道で作ると壊れません。ランキングは必ず数値で降順に並べ、文字数値のままソートしないこと。出力の数値書式（千区切り）を適用して、レビューしやすい見た目に整えます。

クロス集計と見える化：カテゴリ×月の売上表

クロス集計（行＝カテゴリ、列＝月、値＝合計）

' ModSales_Pivot.bas
Option Explicit

' Z=カテゴリ（Clean後の列例）, B=注文日, E=金額
Public Sub PivotCategoryMonth(ByVal sheetName As String, ByVal outStart As String, _
                              ByVal categoryCol As Long, ByVal dateCol As Long, ByVal amountCol As Long)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    Dim cats As Object: Set cats = CreateObject("Scripting.Dictionary"): cats.CompareMode = 1
    Dim months As Object: Set months = CreateObject("Scripting.Dictionary"): months.CompareMode = 1
    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim cat As String: cat = NormKey(a(r, categoryCol))
        Dim dt As Variant: dt = ToDateOrEmpty(a(r, dateCol))
        If Len(cat) > 0 And IsDate(dt) Then
            cats(cat) = True
            months(Format(CDate(dt), "yyyy-mm")) = True
        End If
    Next

    Dim map As Object: Set map = CreateObject("Scripting.Dictionary"): map.CompareMode = 1
    Dim mKeys() As Variant: mKeys = months.Keys
    Dim cKeys() As Variant: cKeys = cats.Keys

    For r = 2 To UBound(a, 1)
        Dim cat As String: cat = NormKey(a(r, categoryCol))
        Dim dt As Variant: dt = ToDateOrEmpty(a(r, dateCol))
        If Len(cat) > 0 And IsDate(dt) Then
            Dim monKey As String: monKey = Format(CDate(dt), "yyyy-mm")
            Dim k As String: k = cat & SEP & monKey
            Dim v As Double: v = ToNumberOrZero(a(r, amountCol))
            map(k) = IIf(map.Exists(k), map(k) + v, v)
        End If
    Next

    Dim out() As Variant: ReDim out(1 To cats.Count + 1, 1 To months.Count + 1)
    out(1, 1) = "Category"
    Dim c As Long
    For c = 0 To UBound(mKeys): out(1, c + 2) = mKeys(c): Next

    Dim i As Long: i = 2
    Dim j As Long
    For j = 0 To UBound(cKeys)
        Dim cat As String: cat = cKeys(j)
        out(i, 1) = cat
        For c = 0 To UBound(mKeys)
            Dim k As String: k = cat & SEP & mKeys(c)
            out(i, c + 2) = IIf(map.Exists(k), map(k), 0#)
        Next
        i = i + 1
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, "", ""
End Sub
VB

重要ポイントの深掘り

クロス集計は「行と列のユニーク集合を先に確定→キー×キーで辞書を引く」の順番が鉄則です。欠損セルはゼロで埋める運用に統一すると、合算やグラフでブレません。カテゴリ列や日付列の番号は環境に合わせて引数で渡せるようにして、列変更に強くします。

例題の通し方：明細整形→顧客別集計→月次→商品トップN→クロス表

パイプライン実行例

' ModSales_Example.bas
Option Explicit

Public Sub Run_SalesPipeline()
    ' 1) 明細整形（YearMonth/CustKey/UnitPrice付与）
    CleanSalesDetail "Detail", "Z1"

    ' 2) 顧客別集計
    AggregateByCustomer "Detail", "AA1"

    ' 3) 月次合計
    AggregateMonthly "Detail", "AC1"

    ' 4) 商品トップ10
    TopNProducts "Detail", "AE1", 10

    ' 5) クロス集計（カテゴリ×月）
    '   例：カテゴリ列=Z（= 26列目）、注文日=A（= 1列目）、金額=E（= 5列目）
    PivotCategoryMonth "Detail", "AG1", 26, 1, 5

    MsgBox "売上集計＋明細整形パイプラインが完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

整形後に年月・正規化キー・単価が正しく付与され、顧客別・月次・商品ランキング・クロス表がヘッダ付きで出力されます。金額列は千区切り、日付は“yyyy-mm-dd”で表示され、見た瞬間にレビュー可能な状態になります。

落とし穴と対策（深掘り）

文字数値・テキスト日付で集計が壊れる

入口で ToNumberOrZero と ToDateOrEmpty を通し、失敗は安全値（0や空）に落とします。並べ替え・平均・合算を壊さないための最重要ポイントです。

キー揺らぎでグループが割れる

NormKey（Trim＋LCase）を必ず両側で適用します。前後空白、大小、全半角のゆれは集計漏れの主因です。

セル逐次書きで遅い・固まる

配列で結果を作り、最後に一括書き戻します。これだけで速度が桁違いに改善し、UIも安定します。

列変更でコードが壊れる

列番号や範囲を関数の引数にし、出力開始セルを運用で固定します。“文字列で列指定”の設計にするとさらに安全です。

まとめ：整形→集計→見える化の一本化で、毎日の売上業務を強くする

正規化と型変換を入口で徹底し、辞書による蓄積と配列一括書き戻しで、顧客別・月次・ランキング・クロスまで軽快に回せます。出力の書式整備まで含めて一本化すると、“使える形”で必ず出てくるので、レビューと意思決定が速くなります。

スポンサーリンク
タイトルとURLをコピーしました