Excel VBA 逆引き集 | デイリー集計

Excel VBA
スポンサーリンク

デイリー集計

毎日の売上や件数を「日付ごとに集計して表へ出す」ためのテンプレを、初心者でもそのまま使える形でまとめました。最短は関数呼び出し、柔軟なら配列＋辞書でグループ化、見た目優先ならAutoFilter、列名前提でも壊れない方法を用意します。

選び方の指針

  • 最短・少量: WorksheetFunction系（SUMIFS/COUNTIFS/AVERAGEIFS）で日別に回す
  • 大量・繰り返し: 配列に読み込み→辞書で日付キー集計（爆速）
  • 見た目で確認しながら: AutoFilterで日付絞り→Sum/Count
  • 列順が変わる現場: 見出し名から列番号を探して安全に処理

基本：SUMIFS/COUNTIFS/AVERAGEIFSで日別に合計・件数・平均

Sub DailySummary_WithFunctions()
    '明細：A=日付, B=商品, C=金額
    Dim dateR As Range, amtR As Range
    Set dateR = Range("A2:A100000")
    Set amtR  = Range("C2:C100000")

    '日付リスト（集計先）：F2:F100 に日付が並んでいる想定
    Dim outLast As Long: outLast = Cells(Rows.Count, "F").End(xlUp).Row
    Dim r As Long, d As Date

    For r = 2 To outLast
        d = Range("F" & r).Value

        '合計
        Range("G" & r).Value = Application.WorksheetFunction.SumIfs( _
                                amtR, dateR, ">=" & CLng(d), dateR, "<" & CLng(d + 1))
        '件数
        Range("H" & r).Value = Application.WorksheetFunction.CountIfs( _
                                dateR, ">=" & CLng(d), dateR, "<" & CLng(d + 1))
        '平均
        On Error Resume Next
        Range("I" & r).Value = Application.WorksheetFunction.AverageIfs( _
                                amtR, dateR, ">=" & CLng(d), dateR, "<" & CLng(d + 1))
        On Error GoTo 0
    Next
End Sub
VB
  • ポイント
    • 日付はシリアルで比較: ">=" & CLng(d) と "<" & CLng(d+1) で「その日だけ」を安定抽出。
    • 時間付きの値でもOK: 境界を翌日未満にすれば1日の範囲に収まる。

爆速：辞書で「日付→合計・件数」を一括集計（時間付きにも強い）

Sub DailySummary_Dictionary()
    '明細：A=日付(時間付きOK), C=金額
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    Dim sumMap As Object: Set sumMap = CreateObject("Scripting.Dictionary")
    Dim cntMap As Object: Set cntMap = CreateObject("Scripting.Dictionary")

    Dim i As Long, d As Date, key As String, amt As Double
    For i = 2 To UBound(v, 1)
        d = DateValue(v(i, 1))                 '時間付きでも日付に丸める
        key = Format$(d, "yyyy-mm-dd")         'キーを文字列に統一
        amt = Val(v(i, 3))

        If sumMap.Exists(key) Then
            sumMap(key) = sumMap(key) + amt
            cntMap(key) = cntMap(key) + 1
        Else
            sumMap.Add key, amt
            cntMap.Add key, 1
        End If
    Next

    '出力：F列=日付, G=合計, H=件数, I=平均
    Dim k As Variant, rOut As Long: rOut = 2
    With Worksheets("集計")
        .Range("F1:I1").Value = Array("日付", "合計", "件数", "平均")
        For Each k In sumMap.Keys
            .Cells(rOut, "F").Value = k
            .Cells(rOut, "G").Value = sumMap(k)
            .Cells(rOut, "H").Value = cntMap(k)
            .Cells(rOut, "I").Value = sumMap(k) / cntMap(k)
            rOut = rOut + 1
        Next
    End With
End Sub
VB
  • ポイント
    • 時間付きでも安全: DateValueで日単位に丸めてからキー化。
    • 一括集計: 合計＋件数→平均もその場で算出。10万行規模でも高速。

列名で安全に日付・金額列を特定して日別集計

Sub DailySummary_ByHeaders()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim head As Range: Set head = rg.Rows(1)

    Dim cDate As Long: cDate = FindHeader(head, "日付")
    Dim cAmt  As Long: cAmt  = FindHeader(head, "金額")
    If cDate * cAmt = 0 Then
        MsgBox "見出しが見つかりません": Exit Sub
    End If

    Dim v As Variant: v = rg.Value
    Dim sumMap As Object: Set sumMap = CreateObject("Scripting.Dictionary")
    Dim cntMap As Object: Set cntMap = CreateObject("Scripting.Dictionary")

    Dim i As Long, d As Date, key As String
    For i = 2 To UBound(v, 1)
        d = DateValue(v(i, cDate))
        key = Format$(d, "yyyy-mm-dd")
        If sumMap.Exists(key) Then
            sumMap(key) = sumMap(key) + Val(v(i, cAmt))
            cntMap(key) = cntMap(key) + 1
        Else
            sumMap.Add key, Val(v(i, cAmt))
            cntMap.Add key, 1
        End If
    Next

    '出力（シート「集計」へ）
    Dim rOut As Long: rOut = 2, k As Variant
    With Worksheets("集計")
        .Range("F1:I1").Value = Array("日付", "合計", "件数", "平均")
        For Each k In sumMap.Keys
            .Cells(rOut, "F").Value = k
            .Cells(rOut, "G").Value = sumMap(k)
            .Cells(rOut, "H").Value = cntMap(k)
            .Cells(rOut, "I").Value = sumMap(k) / cntMap(k)
            rOut = rOut + 1
        Next
    End With
End Sub

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
  • ポイント
    • 列順変更に耐える: 見出し名から列番号を取得して安全に参照。
    • 現場フレンドリー: 列名称が「日付」「金額」以外でも対応可能。

フィルタで日付を選んで見た目の合計・件数（最短）

Sub DailySummary_FilterThenSum()
    With Range("A1").CurrentRegion
        '例：2025/01/15 のみ表示（開始〜翌日未満）
        .AutoFilter Field:=1, Operator:=xlAnd, _
            Criteria1:=">=1/15/2025", Criteria2:="<1/16/2025"

        Dim visSum As Double, visCnt As Long, vis As Range
        On Error Resume Next
        Set vis = .Columns(3).SpecialCells(xlCellTypeVisible) '金額列（C）
        On Error GoTo 0

        If Not vis Is Nothing Then
            visSum = Application.WorksheetFunction.Sum(vis)
            'データ行のみの可視件数（ヘッダー除外）
            visCnt = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Count
        End If

        Range("G2").Value = visSum
        Range("H2").Value = visCnt
        Range("I2").Value = IIf(visCnt > 0, visSum / visCnt, 0)

        .AutoFilter '解除
    End With
End Sub
VB
  • ポイント
    • 目視確認と集計を同時に: 日付範囲で絞って合計/件数/平均を即取得。
    • 解除必須: 最後に.AutoFilterで戻す。

大量データの高速テンプレ（配列で日別集計＋複数指標）

Sub DailySummary_ArrayFast_Metrics()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'A=日時, C=金額, D=数量 の例
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

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

    Dim i As Long, d As Date, key As String
    For i = 2 To UBound(v, 1)
        d = DateValue(v(i, 1))
        key = Format$(d, "yyyy-mm-dd")

        If Not sumAmt.Exists(key) Then
            sumAmt.Add key, 0#: sumQty.Add key, 0#: cnt.Add key, 0
        End If
        sumAmt(key) = sumAmt(key) + Val(v(i, 3))
        sumQty(key) = sumQty(key) + Val(v(i, 4))
        cnt(key) = cnt(key) + 1
    Next

    '出力：F=日付, G=金額合計, H=数量合計, I=平均金額
    Dim keys As Variant: keys = sumAmt.Keys
    Dim n As Long: n = UBound(keys) + 1
    If n > 0 Then
        Dim out() As Variant: ReDim out(1 To n, 1 To 4)
        For i = 0 To UBound(keys)
            out(i + 1, 1) = keys(i)
            out(i + 1, 2) = sumAmt(keys(i))
            out(i + 1, 3) = sumQty(keys(i))
            out(i + 1, 4) = IIf(cnt(keys(i)) > 0, sumAmt(keys(i)) / cnt(keys(i)), 0)
        Next
        With Worksheets("集計")
            .Range("F1:I1").Value = Array("日付", "金額合計", "数量合計", "平均金額")
            .Range("F2").Resize(n, 4).Value = out
        End With
    End If

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント
    • 複数指標の同時集計: 合計・件数・平均・他指標を並行で計算。
    • セル往復ゼロ: 配列→辞書→出力で圧倒的に速い。

よくある落とし穴と対策

  • 日時付きで日別にまとまらない
    • 対策: DateValueで日付へ丸める、キーはFormat$(d, "yyyy-mm-dd")で統一。
  • 日付が文字列で関数が効かない
    • 対策: 事前にDate型へ変換するか、シリアル比較（CLng(date)）を使う。
  • 列順が変わって壊れる
    • 対策: 見出し名からFindで列番号を取得する関数を使う。
  • 0件で平均がエラーになる
    • 対策: 分母ゼロチェックを入れて0やエラー値を明示的に返す。
  • セルアクセスが多くて遅い
    • 対策: 範囲→配列→一括集計→まとめて書き戻しにする。

例題で練習

'例1：日付リスト（F列）に対してSUMIFS/COUNTIFS/AVERAGEIFSで日別指標
Sub Example_FunctionsDaily()
    Call DailySummary_WithFunctions
End Sub

'例2：辞書で日付キーにまとめて合計・件数・平均
Sub Example_DictDaily()
    Call DailySummary_Dictionary
End Sub

'例3：見出し名で列を見つけて、日別集計を安全に実行
Sub Example_ByHeadersDaily()
    Call DailySummary_ByHeaders
End Sub

'例4：大量データで金額合計・数量合計・平均金額を同時に出力
Sub Example_ArrayFastDaily()
    Call DailySummary_ArrayFast_Metrics
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました