Excel VBA 逆引き集 | 連続データの集計

Excel VBA
スポンサーリンク

連続データの集計

「連続した期間（連続日・連続行・連続カテゴリ）をひとまとまりに集計したい」「移動合計や累積で推移を見たい」場面で使えるテンプレを厳選しました。初心者でも壊れにくい実務向けのコードにしています。

目的別の使い分け

  • 累積（ランニングトータル）: 行を追いながら合計を上書きしていく
  • 移動合計・移動平均: 直近 N 件（N 日）の窓で合計/平均
  • 連続ブロック集計: 同じキーや条件が続いている連続区間をひとかたまりに要約
  • 連続日数の算出: 稼働/欠勤などの連続日数と開始・終了を出す
  • 日付の穴埋め→日次集計: 欠番（抜け日）を補完して連続日で集計（後段の月次/週次へも展開可）
  • 大量データ: 範囲→配列で処理し、一括書き戻し（高速・安定）

累積（ランニングトータル）：毎行の合計を更新

Sub RunningTotal_Write()
    'A=日付（昇順推奨）、B=金額、C=累積合計（出力）
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim sumV As Double, r As Long
    sumV = 0
    For r = 2 To last
        sumV = sumV + Val(Cells(r, "B").Value)
        Cells(r, "C").Value = sumV
    Next
    Range("C2:C" & last).NumberFormat = "#,##0"
End Sub
VB
  • ポイント
    • 並び順: 日付・時系列で昇順にしてから実行。
    • 数値化: Val で文字列混入を無害化。

移動合計・移動平均（N件窓）

Sub MovingSumAvg_WindowN()
    'A=日付（昇順）、B=金額、C=直近N件合計、D=直近N件平均
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim N As Long: N = 7 '例：直近7件
    Dim r As Long
    For r = 2 To last
        Dim s As Long: s = Application.Max(2, r - N + 1)
        Cells(r, "C").Value = WorksheetFunction.Sum(Range("B" & s & ":B" & r))
        Cells(r, "D").Value = Cells(r, "C").Value / (r - s + 1)
    Next
    Range("C2:D" & last).NumberFormat = "#,##0"
End Sub
VB
  • ポイント
    • 端の扱い: 先頭側は実データ件数で平均分母を調整。
    • 日付窓（7日間）でやりたい: 下の「日付ベース移動集計」を参照。

連続ブロック集計：条件が続く区間を「開始・終了・長さ・合計」で要約

Sub Aggregate_ConsecutiveBlocks()
    'A=ID/カテゴリ、B=日付（昇順）、C=状態（例：稼働/休止）、D=値（例：数量）
    '集計先：シート「連続集計」に (ID, 状態, 開始日, 終了日, 日数, 合計値)
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("連続集計")
    If outWs Is Nothing Then Set outWs = Worksheets.Add: outWs.Name = "連続集計"
    On Error GoTo 0
    outWs.Cells.Clear
    outWs.Range("A1:F1").Value = Array("ID", "状態", "開始日", "終了日", "日数", "合計")
    
    Dim curID As String, curState As String
    Dim startDate As Date, endDate As Date
    Dim sumVal As Double, r As Long, rOut As Long
    rOut = 2
    
    curID = CStr(Cells(2, "A").Value)
    curState = CStr(Cells(2, "C").Value)
    startDate = Cells(2, "B").Value
    endDate = startDate
    sumVal = Val(Cells(2, "D").Value)
    
    For r = 3 To last
        Dim id As String: id = CStr(Cells(r, "A").Value)
        Dim st As String: st = CStr(Cells(r, "C").Value)
        Dim dt As Date: dt = Cells(r, "B").Value
        Dim v As Double: v = Val(Cells(r, "D").Value)
        
        'IDが変わる or 状態が変わる or 日付が連続していない → ブロック終了
        If id <> curID Or st <> curState Or dt <> endDate + 1 Then
            '出力
            outWs.Cells(rOut, 1).Value = curID
            outWs.Cells(rOut, 2).Value = curState
            outWs.Cells(rOut, 3).Value = startDate
            outWs.Cells(rOut, 4).Value = endDate
            outWs.Cells(rOut, 5).Value = endDate - startDate + 1
            outWs.Cells(rOut, 6).Value = sumVal
            rOut = rOut + 1
            '新ブロック開始
            curID = id: curState = st
            startDate = dt: endDate = dt
            sumVal = v
        Else
            '同一ブロック継続
            endDate = dt
            sumVal = sumVal + v
        End If
    Next
    
    '最後のブロックを出力
    outWs.Cells(rOut, 1).Value = curID
    outWs.Cells(rOut, 2).Value = curState
    outWs.Cells(rOut, 3).Value = startDate
    outWs.Cells(rOut, 4).Value = endDate
    outWs.Cells(rOut, 5).Value = endDate - startDate + 1
    outWs.Cells(rOut, 6).Value = sumVal
    
    outWs.Columns.AutoFit
End Sub
VB
  • ポイント
    • 連続の定義: 「同じID・同じ状態・日付が前日+1」で連続判定。
    • 並び順必須: 事前に A→C→B（ID→状態→日付）昇順でソートしてから実行。

連続日数の算出（最長連続など）をシンプルに

Sub LongestStreak_PerID()
    'A=ID、B=日付（昇順）、C=フラグ（1=稼働, 0=休止）
    '出力：シート「最長連続」に ID, 最長連続日数
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("最長連続")
    If outWs Is Nothing Then Set outWs = Worksheets.Add: outWs.Name = "最長連続"
    On Error GoTo 0
    outWs.Cells.Clear
    outWs.Range("A1:B1").Value = Array("ID", "最長連続日数")
    
    Dim dictMax As Object: Set dictMax = CreateObject("Scripting.Dictionary")
    Dim curID As String, curLen As Long, maxLen As Long
    Dim prevDate As Date, r As Long
    
    curID = CStr(Cells(2, "A").Value)
    curLen = 0: maxLen = 0: prevDate = Cells(2, "B").Value
    
    For r = 2 To last
        Dim id As String: id = CStr(Cells(r, "A").Value)
        Dim dt As Date: dt = Cells(r, "B").Value
        Dim flag As Long: flag = Val(Cells(r, "C").Value)
        
        If id <> curID Then
            dictMax(curID) = Application.Max(dictMax.Exists(curID), maxLen)
            curID = id: curLen = 0: maxLen = 0: prevDate = dt
        End If
        
        If flag = 1 Then
            If dt = prevDate Or dt = prevDate + 1 Then
                curLen = curLen + 1
            Else
                curLen = 1
            End If
            prevDate = dt
            If curLen > maxLen Then maxLen = curLen
        Else
            prevDate = dt
            curLen = 0
        End If
    Next
    '最後のID
    dictMax(curID) = Application.Max(dictMax.Exists(curID), maxLen)
    
    '出力
    Dim k As Variant, rOut As Long: rOut = 2
    For Each k In dictMax.Keys
        outWs.Cells(rOut, 1).Value = k
        outWs.Cells(rOut, 2).Value = dictMax(k)
        rOut = rOut + 1
    Next
    outWs.Columns.AutoFit
End Sub
VB
  • ポイント
    • 定義: 稼働フラグが1の連続日をカウント。欠勤で途切れる。
    • ソート: ID→日付昇順にしてから実行。

日付の穴埋め→日次連続で集計（0補完）

Sub FillMissingDates_AndSumDaily()
    'A=日付、B=金額 → 欠番を0で補完し、連続日で表を作る（出力「日次補完」）
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value
    
    Dim minD As Date, maxD As Date, i As Long
    minD = v(2, 1): maxD = v(2, 1)
    For i = 3 To UBound(v, 1)
        If v(i, 1) < minD Then minD = v(i, 1)
        If v(i, 1) > maxD Then maxD = v(i, 1)
    Next
    
    Dim n As Long: n = CLng(maxD - minD) + 1
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 2)
    out(1, 1) = "日付": out(1, 2) = "金額"
    
    '辞書に日付→合計（同日の複数行がある可能性）
    Dim sumMap As Object: Set sumMap = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(v, 1)
        Dim d As Date: d = DateValue(v(i, 1))
        Dim amt As Double: amt = Val(v(i, 2))
        If sumMap.Exists(CStr(d)) Then sumMap(CStr(d)) = sumMap(CStr(d)) + amt Else sumMap(CStr(d)) = amt
    Next
    
    Dim k As Long, cur As Date: cur = minD
    For k = 1 To n
        out(k + 1, 1) = cur
        out(k + 1, 2) = IIf(sumMap.Exists(CStr(cur)), sumMap(CStr(cur)), 0)
        cur = cur + 1
    Next
    
    With Worksheets("日次補完")
        .Cells.Clear
        .Range("A1").Resize(n + 1, 2).Value = out
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • 0補完: 連続日に整えれば移動平均や折れ線の見栄えが安定。
    • 重複日: 同日複数レコードは合算してから補完。

日付ベースの移動合計（直近N日）にする

Sub MovingSum_ByDays()
    'A=日付、B=金額、C=直近N日合計
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim N As Long: N = 30 '例：直近30日
    Dim r As Long
    For r = 2 To last
        Dim d0 As Date: d0 = Cells(r, "A").Value
        Dim d1 As Date: d1 = d0 - N + 1
        '開始日以上かつ当日以下の合計（時刻混入でも安全）
        Cells(r, "C").Value = WorksheetFunction.SumIfs( _
            Range("B2:B" & last), Range("A2:A" & last), ">=" & CLng(d1), Range("A2:A" & last), "<=" & CLng(d0))
    Next
    Range("C2:C" & last).NumberFormat = "#,##0"
End Sub
VB
  • ポイント
    • シリアル比較: CLng(date) で時刻付きにも強い。
    • 窓ずれ: 「件数窓」ではなく「日数窓」の移動合計。

大量データ高速版：配列で連続ブロック集計

Sub AggregateBlocks_ArrayFast()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim rg As Range: Set rg = Range("A1").CurrentRegion 'A=ID, B=日付, C=状態, D=値
    Dim v As Variant: v = rg.Value
    
    '前提：ID→状態→日付で昇順ソート済み
    Dim rowsOut As Collection: Set rowsOut = New Collection
    rowsOut.Add Array("ID", "状態", "開始日", "終了日", "日数", "合計")
    
    Dim i As Long, curID As String, curSt As String
    Dim startD As Date, endD As Date, sumV As Double
    
    curID = CStr(v(2, 1)): curSt = CStr(v(2, 3))
    startD = v(2, 2): endD = startD
    sumV = Val(v(2, 4))
    
    For i = 3 To UBound(v, 1)
        Dim id As String: id = CStr(v(i, 1))
        Dim st As String: st = CStr(v(i, 3))
        Dim d As Date: d = v(i, 2)
        Dim val As Double: val = Val(v(i, 4))
        
        If id <> curID Or st <> curSt Or d <> endD + 1 Then
            rowsOut.Add Array(curID, curSt, startD, endD, endD - startD + 1, sumV)
            curID = id: curSt = st: startD = d: endD = d: sumV = val
        Else
            endD = d: sumV = sumV + val
        End If
    Next
    rowsOut.Add Array(curID, curSt, startD, endD, endD - startD + 1, sumV)
    
    Dim n As Long: n = rowsOut.Count
    Dim out() As Variant: ReDim out(1 To n, 1 To 6)
    For i = 1 To n
        Dim a As Variant: a = rowsOut(i)
        Dim j As Long
        For j = 1 To 6: out(i, j) = a(j - 1): Next
    Next
    
    With Worksheets("連続集計")
        .Cells.Clear
        .Range("A1").Resize(n, 6).Value = out
        .Columns.AutoFit
    End With
    
Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント
    • セル往復ゼロ: 配列→コレクション→一括貼付で高速。
    • 汎用性: キーや条件は列名に合わせて差し替え可。

よくある落とし穴と対策

  • 並び順が乱れて連続判定が誤る
    • 対策: 事前にキー→日付で昇順ソートする（ID→状態→日付など）。
  • 時刻付きで連続判定がズレる
    • 対策: DateValueで日付に丸めるか、比較はシリアル値（CLng(date)）で行う。
  • 数値が文字列で計算されない
    • 対策: Val で安全に数値化。式は .Value = .Value で値化。
  • 大規模で遅い
    • 対策: 配列処理に切り替え、前後で画面更新・イベント・計算を停止→復帰。

例題で練習

'例1：累積（ランニングトータル）をC列に出力
Sub Example_Running()
    Call RunningTotal_Write
End Sub

'例2：直近7件の移動合計・平均
Sub Example_MovingN()
    Call MovingSumAvg_WindowN
End Sub

'例3：連続ブロックを「開始・終了・日数・合計」で要約
Sub Example_Blocks()
    Call Aggregate_ConsecutiveBlocks
End Sub

'例4：IDごとの最長連続日数を算出
Sub Example_LongestStreak()
    Call LongestStreak_PerID
End Sub

'例5：欠番を0補完して日次連続表を生成
Sub Example_FillDaily()
    Call FillMissingDates_AndSumDaily
End Sub

'例6：大量データを配列で高速ブロック集計
Sub Example_ArrayFastBlocks()
    Call AggregateBlocks_ArrayFast
End Sub
VB

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