ここでは 一致件数を集計してレポート化 と 一致セルを別ファイルに抽出 の VBA 実務テンプレートをまとめました。
一致件数を集計してレポート化版
Sub RangeToArray_NGWordCheck_Report()
Dim wsData As Worksheet
Dim wsNG As Worksheet
Dim wsReport As Worksheet
Dim rng As Range
Dim arr As Variant
Dim ngArr As Variant
Dim i As Long, j As Long, k As Long
Dim regEx As Object
Dim dict As Object
' シート指定
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsNG = ThisWorkbook.Sheets("NGWords")
Set wsReport = ThisWorkbook.Sheets("Report")
' データ範囲
Set rng = wsData.Range("A1:C1000")
arr = rng.Value
' NGワードリスト
ngArr = wsNG.Range("A1", wsNG.Cells(wsNG.Rows.Count, "A").End(xlUp)).Value
' 正規表現
Set regEx = CreateObject("VBScript.RegExp")
regEx.IgnoreCase = True
regEx.Global = True
' 集計用 Dictionary
Set dict = CreateObject("Scripting.Dictionary")
' チェック処理＋集計
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 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
rng.Cells(i, j).Interior.Color = vbRed
rng.Cells(i, j).Font.Bold = True
' 集計カウント
If Not dict.Exists(ngArr(k, 1)) Then
dict.Add ngArr(k, 1), 1
Else
dict(ngArr(k, 1)) = dict(ngArr(k, 1)) + 1
End If
Exit For
End If
Next k
End If
Next j
Next i
' レポート出力
wsReport.Cells.Clear
wsReport.Range("A1:B1").Value = Array("NGWord", "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
' 書戻し
rng.Value = arr
End Sub
一致セルを別ファイルに抽出版
Sub RangeToArray_NGWordCheck_ExportToFile()
Dim wsData As Worksheet
Dim wsNG As Worksheet
Dim rng As Range
Dim arr As Variant
Dim ngArr As Variant
Dim i As Long, j As Long, k As Long
Dim regEx As Object
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim row As Long
' シート指定
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsNG = ThisWorkbook.Sheets("NGWords")
' データ範囲
Set rng = wsData.Range("A1:C1000")
arr = rng.Value
' NGワードリスト
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 wbNew = Workbooks.Add
Set wsNew = wbNew.Sheets(1)
wsNew.Range("A1:D1").Value = Array("Row", "Col", "Value", "MatchedPattern")
row = 2
' チェック処理＋抽出
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 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
rng.Cells(i, j).Interior.Color = vbRed
rng.Cells(i, j).Font.Bold = True
' 新ファイルに抽出
wsNew.Cells(row, 1).Value = i
wsNew.Cells(row, 2).Value = j
wsNew.Cells(row, 3).Value = arr(i, j)
wsNew.Cells(row, 4).Value = ngArr(k, 1)
row = row + 1
Exit For
End If
Next k
End If
Next j
Next i
' 書戻し
rng.Value = arr
' 新ファイルを保存（例：デスクトップに保存）
wbNew.SaveAs ThisWorkbook.Path & "\NGWord_Extract.xlsx"
End Sub
実務での活用イメージ
- 一致件数レポート化 → NGワードごとの発生頻度を一覧化して監査報告に利用
- 一致セル抽出 → 問題データだけを別ファイルにまとめて共有・提出
👉 このテンプレを使えば「チェック → 集計 → レポート → 抽出」まで一気に自動化できます。
さらに応用すると「一致件数をグラフ化」「抽出ファイルをメール送信」なども可能です。