ここでは 週単位・月単位で集計してグラフ化する VBA 実務テンプレート をまとめました。これで「日付ごとの一致件数」をさらに 週別・月別に集計 → グラフ化 できます。
週単位で集計してグラフ化
Sub RangeToArray_NGWordCheck_WeeklyChart()
Dim wsData As Worksheet, wsNG As Worksheet, wsReport As Worksheet
Dim rng As Range, arr As Variant, ngArr As Variant
Dim i As Long, j As Long, k As Long
Dim regEx As Object, dict As Object
Dim chartObj As ChartObject
Dim logDate As Variant, weekKey As String
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsNG = ThisWorkbook.Sheets("NGWords")
Set wsReport = ThisWorkbook.Sheets("Report")
Set rng = wsData.Range("A2:C1000")
arr = rng.Value
ngArr = wsNG.Range("A1", wsNG.Cells(wsNG.Rows.Count, "A").End(xlUp)).Value
Set regEx = CreateObject("VBScript.RegExp")
regEx.IgnoreCase = True
regEx.Global = True
Set dict = CreateObject("Scripting.Dictionary")
' 日付ごとに週番号をキーにして集計
For i = LBound(arr, 1) To UBound(arr, 1)
logDate = arr(i, 1)
If IsDate(logDate) Then
weekKey = Format(logDate, "YYYY-ww") ' 年-週番号
For j = 2 To UBound(arr, 2)
If VarType(arr(i, j)) = vbString Then
For k = LBound(ngArr, 1) To UBound(ngArr, 1)
regEx.Pattern = ngArr(k, 1)
If regEx.Test(arr(i, j)) Then
If Not dict.Exists(weekKey) Then
dict.Add weekKey, 1
Else
dict(weekKey) = dict(weekKey) + 1
End If
Exit For
End If
Next k
End If
Next j
End If
Next i
' レポート出力
wsReport.Cells.Clear
wsReport.Range("A1:B1").Value = Array("Week", "Count")
Dim row As Long: row = 2
For Each k In dict.Keys
wsReport.Cells(row, 1).Value = k
wsReport.Cells(row, 2).Value = dict(k)
row = row + 1
Next k
' グラフ作成（折れ線）
wsReport.ChartObjects.Delete
Set chartObj = wsReport.ChartObjects.Add(Left:=250, Top:=50, Width:=500, Height:=300)
With chartObj.Chart
.ChartType = xlLineMarkers
.SetSourceData Source:=wsReport.Range("A1:B" & row - 1)
.HasTitle = True
.ChartTitle.Text = "週単位 NGワード一致件数"
.Axes(xlCategory).AxisTitle.Text = "Week"
.Axes(xlValue).AxisTitle.Text = "Count"
End With
End Sub
月単位で集計してグラフ化
Sub RangeToArray_NGWordCheck_MonthlyChart()
Dim wsData As Worksheet, wsNG As Worksheet, wsReport As Worksheet
Dim rng As Range, arr As Variant, ngArr As Variant
Dim i As Long, j As Long, k As Long
Dim regEx As Object, dict As Object
Dim chartObj As ChartObject
Dim logDate As Variant, monthKey As String
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsNG = ThisWorkbook.Sheets("NGWords")
Set wsReport = ThisWorkbook.Sheets("Report")
Set rng = wsData.Range("A2:C1000")
arr = rng.Value
ngArr = wsNG.Range("A1", wsNG.Cells(wsNG.Rows.Count, "A").End(xlUp)).Value
Set regEx = CreateObject("VBScript.RegExp")
regEx.IgnoreCase = True
regEx.Global = True
Set dict = CreateObject("Scripting.Dictionary")
' 日付ごとに月単位で集計
For i = LBound(arr, 1) To UBound(arr, 1)
logDate = arr(i, 1)
If IsDate(logDate) Then
monthKey = Format(logDate, "YYYY-MM") ' 年-月
For j = 2 To UBound(arr, 2)
If VarType(arr(i, j)) = vbString Then
For k = LBound(ngArr, 1) To UBound(ngArr, 1)
regEx.Pattern = ngArr(k, 1)
If regEx.Test(arr(i, j)) Then
If Not dict.Exists(monthKey) Then
dict.Add monthKey, 1
Else
dict(monthKey) = dict(monthKey) + 1
End If
Exit For
End If
Next k
End If
Next j
End If
Next i
' レポート出力
wsReport.Cells.Clear
wsReport.Range("A1:B1").Value = Array("Month", "Count")
Dim row As Long: row = 2
For Each k In dict.Keys
wsReport.Cells(row, 1).Value = k
wsReport.Cells(row, 2).Value = dict(k)
row = row + 1
Next k
' グラフ作成（折れ線）
wsReport.ChartObjects.Delete
Set chartObj = wsReport.ChartObjects.Add(Left:=250, Top:=50, Width:=500, Height:=300)
With chartObj.Chart
.ChartType = xlLineMarkers
.SetSourceData Source:=wsReport.Range("A1:B" & row - 1)
.HasTitle = True
.ChartTitle.Text = "月単位 NGワード一致件数"
.Axes(xlCategory).AxisTitle.Text = "Month"
.Axes(xlValue).AxisTitle.Text = "Count"
End With
End Sub
実務での活用イメージ
- 週単位集計 → 毎週の監査レポートに活用
- 月単位集計 → 月次報告書やコンプライアンスレポートに活用
- 折れ線グラフ → 時系列推移を直感的に把握可能
👉 このテンプレを使えば「日付ごと → 週単位 → 月単位」と柔軟に集計できます。
さらに応用すると「年単位で集計」「週・月を同じグラフに重ねて比較」も可能です。