はじめに
前回の初級編では、Excelのセル単位での文章校正ツールを作成しました。
今回の中級編では、実務でよくある「大量の文書をレビューする」業務を自動化します。
こんな課題を解決します
- 月末に各部署から提出される50個の報告書を確認する
- 営業資料のテンプレート集を会社基準に統一したい
- 1ファイルずつ開いてチェックすると1時間以上かかる
- 同じ指摘を何度も繰り返すのが非効率
→ これをVBAと生成AIで完全自動化するという提案です。
Microsoft Copilotとの違いは？
とはいっても、これって「Word Copilotでもできるのでは？」という疑問に答えます。
機能比較表
| 機能 | Word Copilot | このVBAツール |
|---|---|---|
| 一括処理 | × 1ファイルずつ開く必要 | ◎50ファイル自動処理 |
| 独自ルール適用 | × 毎回説明が必要 | ◎ 社内基準を完全実装 |
| 処理時間 | 手動で各ファイル処理（約60分） | ◎ 自動で一括処理（約5分） |
| 結果管理 | × 個別に確認 | ◎ Excel一覧で比較 |
| 夜間実行 | × 不可 | ◎ タスクスケジューラで可能 |
| 監査証跡 | × 残らない | ◎ 全処理ログを記録 |
| カスタマイズ | △ 限定的 | ◎ プロンプト自由設計 |
| コスト | 月額$30/ユーザー | 従量課金（約$0.50/50件） |
◎ Copilotが優れている場合
- 1〜2ファイルの詳細なレビュー
- デザインやレイアウトの提案も欲しい
- 対話的にレビューを進めたい
◎ このツールが優れている場合
- 10ファイル以上の一括処理
- 会社独自の厳密なルール適用
- 定期的な大量レビュー作業
- 処理結果の一覧管理・比較
このように、CopilotではできないことをVBAで作ることができます。
システム構成
┌─────────────────────┐
│ フォルダ内のWord文書 │
│ ├ 報告書_01.docx │
│ ├ 報告書_02.docx │
│ ... │
│ └ 報告書_50.docx │
└──────────┬──────────┘
│ VBAで自動読み込み
▼
┌─────────────────────┐
│ 会社独自ルール適用 │
│ ・禁止表現チェック │
│ ・推奨表現への変換 │
│ ・トーン統一確認 │
└──────────┬──────────┘
│ OpenAI API
▼
┌─────────────────────┐
│ AIレビュー結果 │
│ ・総合評価 │
│ ・NG項目数 │
│ ・具体的な指摘事項 │
│ ・改善提案 │
└──────────┬──────────┘
│
▼
┌─────────────────────┐
│ Excelレポート出力 │
│ (一覧で比較可能) │
└─────────────────────┘
会社独自ルールの実装
なぜ独自ルールが重要なのか
一般的なAIは汎用的な文章改善はできますが、会社固有の表現ルールには対応できません。
例：実際の社内ルール
- 禁止：「弊社」「〜の方」「〜させて頂く」
- 推奨：「弊社」→「当社」、「お客様」→「お取引先様」
- 必須：「です・ます調」統一、3行以内推奨
Copilotでやると１つの文書に対し毎回毎回指示する必要がある場合もあり、大変です。
※※この記事では例として書いています
ツール作成の手順
全体の流れ
①チェックするファイルを用意
②VBAを動かす
└─ チェックするファイルを入れたフォルダを指定
└─ API接続
└─ チェック対象のWord文書をチェック
└─ 修正対象のものがあればExcelシートに書きだす
└─ ファイルをすべて読み込んだら「修正しますか？」と聞く
└─ 修正が済んだら別名保存
③終了
この流れで進めていきます。
①サンプルWord作成
まずサンプルとなるWordファイルを作成します。
例
サンプル1: 報告書_営業部_01.docx
【月次営業報告書】
お世話になります。営業部の佐藤です。
今月の売上の方につきまして、ご報告させて頂きます。
弊社の営業活動におきましては、新規顧客の獲得に注力させて頂いており、
前月比で120%の売上を達成する事が出来ました。
特に、A社様との商談が順調に進んでおりまして、来月の受注が見込まれます。
引き続き、営業活動を頑張って参ります。
宜しくお願い致します。
サンプル2: 報告書_営業部_02.docx
【週次営業報告】
お疲れ様です。
今週の営業活動について報告します。
・新規商談3件
・既存顧客フォロー5件
・見積提出2件
課題としては、競合他社の価格攻勢が激しく、値引き要求が増えている。
対策として、付加価値提案を強化していく方針です。
以上
サンプル3: 報告書_技術部_01.docx
【システム開発進捗報告】
システム開発プロジェクトの進捗を報告します。
現在の進捗率は約80パーセントです。
主な成果物は以下の通り。
・基本設計書の完成
・データベース設計の完了
・API実装（進行中）
問題点としては、外部APIの仕様変更があり、
対応に追加で2週間くらいかかりそうです。
リリース予定日は3月末を想定してます。
サンプル4: 報告書_経営層向け_01.docx
【第1四半期 業績サマリー】
当社の第1四半期業績につきまして、下記の通りご報告いたします。
売上高：1億2000万円（前年比+15%）
営業利益：2500万（前年比+20%）
純利益：1800万（前年比+18%）
主な成長要因は新規事業部門の好調な立ち上がりによるものです。
今後の課題としては人材確保と組織体制の強化が挙げられます。
第2四半期も引き続き成長軌道を維持する見込みでございます。
サンプル5: 提案書_顧客向け_01.docx
【ソリューション提案書】
お世話になります。株式会社サンプルの田中です。
先日はお時間を頂きまして、誠にありがとうございました。
弊社のサービスにつきまして、改めてご説明させて頂きます。
弊社のクラウドサービスは、中小企業向けに特化した
コストパフォーマンスに優れたソリューションとなっております。
料金の方は月額5万円からとなっており、
初期費用は無料とさせて頂いております。
導入実績は100社以上となっております。
ご検討の程、宜しくお願い致します。
これらのサンプルファイルを、テスト用Word文書というフォルダ内に保存しておきます。
つまり、完成形は以下の通り
デスクトップ（例えばデスクトップ上にフォルダを作ったとして）
└─ テスト用Word文書
├─ 報告書_営業部_01.docx
├─ 報告書_営業部_02.docx
├─ 報告書_技術部_01.docx
├─ 報告書_経営層向け_01.docx
└─ 提案書_顧客向け_01.docx
●確認ポイント
上記サンプルファイルには以下のような問題を意図的に入れてあります。
報告書_営業部_01.docx
× 「弊社」（禁止表現）
× 「〜の方」（冗長表現）
× 「〜させて頂く」（不適切な敬語）
× 「宜しく」（正しくは「よろしく」）
× 「致します」（正しくは「いたします」）
報告書_営業部_02.docx
比較的良好な文章にしてあります。
△「競合他社の価格攻勢が激しく、」（やや口語的）
報告書_技術部_01.docx
×「約80パーセント」（単位表記の不統一）
× 「2週間くらい」（曖昧な表現）
× 「〜してます」（文末の不統一）
報告書_経営層向け_01.docx
概ね適切にしてあります。
△ 数値に単位あり（OK）
提案書_顧客向け_01.docx
×「弊社」多数
× 「〜の方」多数
× 「〜させて頂く」多数
× 「宜しく」
これらをチェックできるように用意しました。
②Excelを開いてコードを実装
Excelを開き、開発タブからコードウィンドウを開き、プロジェクト内で「標準モジュール」を作成。
そして開いたウィンドウに以下のコードを貼り付けます。
Option Explicit
' ===================================
' Word文書 AI一括レビューツール
' 中級編：会社独自ルール対応版
' ===================================
' API設定
Private Const API_KEY As String = "YOUR_OPENAI_API_KEY"
Private Const API_ENDPOINT As String = "https://api.openai.com/v1/chat/completions"
' 会社独自ルール
Private Type CompanyRules
禁止表現 As String
推奨表現 As String
必須トーン As String
その他ルール As String
End Type
' メイン処理：フォルダ内のWord文書を一括レビュー
Sub Word文書を一括レビュー()
Dim folderPath As String
Dim files() As String
Dim fileCount As Long
Dim i As Long
Dim startTime As Double
' フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Word文書が格納されているフォルダを選択"
If .Show = -1 Then
folderPath = .SelectedItems(1)
Else
MsgBox "キャンセルされました。", vbInformation
Exit Sub
End If
End With
' Word文書ファイル一覧を取得
files = GetWordFiles(folderPath)
fileCount = UBound(files) - LBound(files) + 1
If fileCount = 0 Then
MsgBox "フォルダ内にWord文書（.docx）が見つかりませんでした。", vbExclamation
Exit Sub
End If
' 確認メッセージ
If MsgBox(fileCount & "個のWord文書をレビューします。" & vbCrLf & _
"処理には時間がかかる場合があります。よろしいですか？", _
vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
' 処理開始
Application.ScreenUpdating = False
Application.DisplayAlerts = False
startTime = Timer
' 結果シートを準備
Call PrepareResultSheet
' 各ファイルを処理
For i = LBound(files) To UBound(files)
Application.StatusBar = "処理中... (" & (i + 1) & "/" & fileCount & ") " & files(i)
Call ProcessWordFile(files(i))
DoEvents
Next i
' 後処理
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
' 結果表示
Dim elapsedTime As Long
elapsedTime = Timer - startTime
MsgBox "一括レビューが完了しました！" & vbCrLf & _
"処理ファイル数: " & fileCount & vbCrLf & _
"処理時間: 約" & elapsedTime & "秒" & vbCrLf & vbCrLf & _
"結果は「レビュー結果」シートに出力されました。", vbInformation
' 結果シートをアクティブに
Sheets("レビュー結果").Activate
End Sub
' フォルダ内のWord文書一覧を取得
Private Function GetWordFiles(folderPath As String) As String()
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim fileList() As String
Dim count As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)
count = 0
ReDim fileList(0 To 0)
For Each file In folder.files
If LCase(fso.GetExtensionName(file.Name)) = "docx" Then
If count > 0 Then ReDim Preserve fileList(0 To count)
fileList(count) = file.Path
count = count + 1
End If
Next file
If count = 0 Then
ReDim fileList(0 To 0)
fileList(0) = ""
End If
GetWordFiles = fileList
End Function
' 結果シートを準備
Private Sub PrepareResultSheet()
Dim ws As Worksheet
' 既存シートを削除
On Error Resume Next
Application.DisplayAlerts = False
Sheets("レビュー結果").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' 新規シート作成
Set ws = Sheets.Add(Before:=Sheets(1))
ws.Name = "レビュー結果"
' ヘッダー設定
With ws
.Range("A1").Value = "No."
.Range("B1").Value = "ファイル名"
.Range("C1").Value = "処理日時"
.Range("D1").Value = "総合評価"
.Range("E1").Value = "NG項目数"
.Range("F1").Value = "指摘事項"
.Range("G1").Value = "改善提案"
.Range("H1").Value = "元の文章（抜粋）"
' ヘッダーの書式設定
With .Range("A1:H1")
.Font.Bold = True
.Interior.Color = RGB(68, 114, 196)
.Font.Color = RGB(255, 255, 255)
.HorizontalAlignment = xlCenter
End With
' 列幅調整
.Columns("A:A").ColumnWidth = 5
.Columns("B:B").ColumnWidth = 30
.Columns("C:C").ColumnWidth = 18
.Columns("D:D").ColumnWidth = 12
.Columns("E:E").ColumnWidth = 12
.Columns("F:F").ColumnWidth = 50
.Columns("G:G").ColumnWidth = 50
.Columns("H:H").ColumnWidth = 40
End With
End Sub
' 個別Word文書を処理
Private Sub ProcessWordFile(filePath As String)
Dim wordApp As Object
Dim doc As Object
Dim docText As String
Dim fileName As String
Dim reviewResult As String
Dim ws As Worksheet
Dim nextRow As Long
On Error GoTo ErrorHandler
' Wordアプリケーションを取得（既存インスタンスを使用）
On Error Resume Next
Set wordApp = GetObject(, "Word.Application")
If wordApp Is Nothing Then
Set wordApp = CreateObject("Word.Application")
End If
On Error GoTo ErrorHandler
wordApp.Visible = False
' 文書を開く
Set doc = wordApp.Documents.Open(filePath, ReadOnly:=True)
' テキストを抽出
docText = doc.content.text
' ファイル名を取得
fileName = doc.Name
' 文書を閉じる
doc.Close False
' テキストが空の場合はスキップ
If Len(Trim(docText)) = 0 Then
GoTo CleanUp
End If
' AIでレビュー
reviewResult = ReviewWithAI(docText, fileName)
' 結果をExcelに記録
Set ws = Sheets("レビュー結果")
nextRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row + 1
Call WriteResultToExcel(ws, nextRow, fileName, docText, reviewResult)
CleanUp:
' Wordアプリケーションは開いたままにする（次の処理で再利用）
Exit Sub
ErrorHandler:
Debug.Print "Error processing file: " & filePath & " - " & Err.Description
' エラーログを記録
Set ws = Sheets("レビュー結果")
nextRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row + 1
ws.Cells(nextRow, 1).Value = nextRow - 1
ws.Cells(nextRow, 2).Value = fileName
ws.Cells(nextRow, 3).Value = Now
ws.Cells(nextRow, 4).Value = "エラー"
ws.Cells(nextRow, 6).Value = "処理エラー: " & Err.Description
On Error Resume Next
If Not doc Is Nothing Then doc.Close False
On Error GoTo 0
End Sub
' AIでレビュー
Private Function ReviewWithAI(docText As String, fileName As String) As String
Dim prompt As String
Dim rules As CompanyRules
' 会社独自ルールを取得
rules = GetCompanyRules()
' プロンプト作成
prompt = CreateReviewPrompt(docText, rules)
' API呼び出し
ReviewWithAI = CallOpenAI(prompt)
End Function
' 会社独自ルールを取得
Private Function GetCompanyRules() As CompanyRules
Dim rules As CompanyRules
' ここで会社独自のルールを定義
' 実際の運用では、外部ファイル（JSON/Excel）から読み込むことを推奨
rules.禁止表現 = "「弊社」「?の方」「?させて頂く」「宜しく」「致します」（「いたします」を推奨）"
rules.推奨表現 = "「弊社」→「当社」" & vbCrLf & _
"「お客様」→「お取引先様」" & vbCrLf & _
"「製品」→「ソリューション」"
rules.必須トーン = "です・ます調で統一。丁寧かつ簡潔に。"
rules.その他ルール = "・文章は3行以内を推奨" & vbCrLf & _
"・専門用語には必ず説明を付ける" & vbCrLf & _
"・数値には必ず単位を明記"
GetCompanyRules = rules
End Function
' レビュー用プロンプトを作成
Private Function CreateReviewPrompt(docText As String, rules As CompanyRules) As String
Dim prompt As String
Dim textSample As String
' 長すぎる場合は先頭2000文字のみ使用
If Len(docText) > 2000 Then
textSample = Left(docText, 2000) & vbCrLf & "...(以下省略)"
Else
textSample = docText
End If
prompt = "以下のビジネス文書を、会社の文書作成基準に基づいてレビューしてください。" & vbCrLf & vbCrLf
prompt = prompt & "【会社の文書作成基準】" & vbCrLf
prompt = prompt & "1. 禁止表現: " & rules.禁止表現 & vbCrLf
prompt = prompt & "2. 推奨表現: " & vbCrLf & rules.推奨表現 & vbCrLf
prompt = prompt & "3. 必須トーン: " & rules.必須トーン & vbCrLf
prompt = prompt & "4. その他ルール: " & vbCrLf & rules.その他ルール & vbCrLf & vbCrLf
prompt = prompt & "【レビュー依頼】" & vbCrLf
prompt = prompt & "以下の形式でJSON形式で出力してください：" & vbCrLf
prompt = prompt & "{" & vbCrLf
prompt = prompt & " ""総合評価"": ""OK"" または ""要修正""," & vbCrLf
prompt = prompt & " ""NG項目数"": 数値," & vbCrLf
prompt = prompt & " ""指摘事項"": ""箇条書きで列挙""," & vbCrLf
prompt = prompt & " ""改善提案"": ""具体的な修正案""" & vbCrLf
prompt = prompt & "}" & vbCrLf & vbCrLf
prompt = prompt & "【対象文書】" & vbCrLf & textSample
CreateReviewPrompt = prompt
End Function
' OpenAI APIを呼び出す
Private Function CallOpenAI(prompt As String) As String
Dim http As Object
Dim jsonRequest As String
Dim response As String
On Error GoTo ErrorHandler
Set http = CreateObject("MSXML2.XMLHTTP")
jsonRequest = "{" & _
"""model"": ""gpt-4o-mini""," & _
"""messages"": [{""role"": ""user"", ""content"": """ & EscapeJson(prompt) & """}]," & _
"""temperature"": 0.3" & _
"}"
http.Open "POST", API_ENDPOINT, False
http.setRequestHeader "Content-Type", "application/json"
http.setRequestHeader "Authorization", "Bearer " & API_KEY
http.send jsonRequest
response = http.responseText
If http.Status = 200 Then
CallOpenAI = ParseJsonResponse(response)
Else
CallOpenAI = "[API Error: " & http.Status & "]"
End If
Exit Function
ErrorHandler:
CallOpenAI = "[Error: " & Err.Description & "]"
End Function
' JSON文字列をエスケープ
Private Function EscapeJson(text As String) As String
Dim result As String
result = text
result = Replace(result, "\", "\\")
result = Replace(result, """", "\""")
result = Replace(result, vbCrLf, "\n")
result = Replace(result, vbCr, "\n")
result = Replace(result, vbLf, "\n")
result = Replace(result, vbTab, "\t")
EscapeJson = result
End Function
' JSONレスポンスを解析
Private Function ParseJsonResponse(jsonText As String) As String
Dim startPos As Long
Dim endPos As Long
Dim content As String
Dim i As Long
Dim char As String
Dim escaped As Boolean
startPos = InStr(jsonText, """content"":""")
If startPos = 0 Then
startPos = InStr(jsonText, """content"": """)
If startPos = 0 Then
ParseJsonResponse = ""
Exit Function
End If
startPos = startPos + Len("""content"": """)
Else
startPos = startPos + Len("""content"":""")
End If
i = startPos
escaped = False
Do While i <= Len(jsonText)
char = Mid(jsonText, i, 1)
If escaped Then
escaped = False
ElseIf char = "\" Then
escaped = True
ElseIf char = """" Then
endPos = i
Exit Do
End If
i = i + 1
Loop
If endPos = 0 Then
ParseJsonResponse = ""
Exit Function
End If
content = Mid(jsonText, startPos, endPos - startPos)
content = Replace(content, "\n", vbCrLf)
content = Replace(content, "\""", """")
content = Replace(content, "\\", "\")
ParseJsonResponse = content
End Function
' 結果をExcelに書き込み
Private Sub WriteResultToExcel(ws As Worksheet, rowNum As Long, fileName As String, docText As String, reviewResult As String)
Dim 総合評価 As String
Dim NG項目数 As String
Dim 指摘事項 As String
Dim 改善提案 As String
' JSONをパース（簡易版）
Call ParseReviewResult(reviewResult, 総合評価, NG項目数, 指摘事項, 改善提案)
' Excelに書き込み
With ws
.Cells(rowNum, 1).Value = rowNum - 1 ' No.
.Cells(rowNum, 2).Value = fileName ' ファイル名
.Cells(rowNum, 3).Value = Now ' 処理日時
.Cells(rowNum, 4).Value = 総合評価 ' 総合評価
.Cells(rowNum, 5).Value = NG項目数 ' NG項目数
.Cells(rowNum, 6).Value = 指摘事項 ' 指摘事項
.Cells(rowNum, 7).Value = 改善提案 ' 改善提案
.Cells(rowNum, 8).Value = Left(docText, 200) & "..." ' 元の文章（抜粋）
' 総合評価に応じて色分け
If 総合評価 = "OK" Then
.Cells(rowNum, 4).Interior.Color = RGB(198, 239, 206) ' 緑
ElseIf 総合評価 = "要修正" Then
.Cells(rowNum, 4).Interior.Color = RGB(255, 199, 206) ' 赤
End If
' セルの書式設定
.Cells(rowNum, 3).NumberFormat = "yyyy/mm/dd hh:mm:ss"
.Range(.Cells(rowNum, 6), .Cells(rowNum, 7)).WrapText = True
End With
End Sub
' レビュー結果をパース（簡易版）
Private Sub ParseReviewResult(jsonResult As String, 総合評価 As String, NG項目数 As String, 指摘事項 As String, 改善提案 As String)
Dim lines() As String
Dim line As String
Dim i As Long
' JSON形式のレスポンスを簡易的にパース
' 実際の運用では、JSON専用ライブラリの使用を推奨
総合評価 = ExtractJsonValue(jsonResult, "総合評価")
NG項目数 = ExtractJsonValue(jsonResult, "NG項目数")
指摘事項 = ExtractJsonValue(jsonResult, "指摘事項")
改善提案 = ExtractJsonValue(jsonResult, "改善提案")
' デフォルト値
If 総合評価 = "" Then 総合評価 = "不明"
If NG項目数 = "" Then NG項目数 = "-"
If 指摘事項 = "" Then 指摘事項 = jsonResult
If 改善提案 = "" Then 改善提案 = "-"
End Sub
' JSON値を抽出（簡易版）
Private Function ExtractJsonValue(jsonText As String, key As String) As String
Dim startPos As Long
Dim endPos As Long
Dim searchKey As String
searchKey = """" & key & """:"
startPos = InStr(jsonText, searchKey)
If startPos = 0 Then
ExtractJsonValue = ""
Exit Function
End If
startPos = startPos + Len(searchKey)
' 値の開始位置を探す
Do While Mid(jsonText, startPos, 1) = " " Or Mid(jsonText, startPos, 1) = """"
startPos = startPos + 1
Loop
' 値の終了位置を探す
endPos = InStr(startPos, jsonText, """")
If endPos = 0 Then
endPos = InStr(startPos, jsonText, ",")
If endPos = 0 Then
endPos = InStr(startPos, jsonText, "}")
End If
End If
If endPos > startPos Then
ExtractJsonValue = Trim(Mid(jsonText, startPos, endPos - startPos))
ExtractJsonValue = Replace(ExtractJsonValue, """", "")
ExtractJsonValue = Replace(ExtractJsonValue, ",", "")
Else
ExtractJsonValue = ""
End If
End Function
' 全Wordインスタンスを閉じる（処理完了後に実行）
Sub Word終了()
Dim wordApp As Object
On Error Resume Next
Set wordApp = GetObject(, "Word.Application")
If Not wordApp Is Nothing Then
wordApp.Quit
Set wordApp = Nothing
MsgBox "Wordアプリケーションを終了しました。", vbInformation
Else
MsgBox "起動中のWordアプリケーションはありません。", vbInformation
End If
On Error GoTo 0
End Sub
③コードの修正
APIコードを置き換える
以下の部分で、ご自分のAPIコードに置き換えて保存する
※「"YOUR_OPENAI_API_KEY"」となっている部分がそうです
' API設定
Private Const API_KEY As String = "YOUR_OPENAI_API_KEY"
これで完了です。
後は好みでシート状にボタンを作成し、そのボタンをクリックするとコードが動くようにしておけば楽です。
動作説明
①VBAを実行させると、フォルダダイアログボックスが開きます。
ここで、Word文書が入っているフォルダを指定します。
②次はこのようなダイアログボックスが開きます。
ここでは「はい」を押します。するとVBAが実行されます。
実行中かどうかはExcelの下の方で確認します。
③レビューが終了したらメッセージが出てきます。
④もし修正したい内容があれば、シートにはこのように出ます。
⑤同時に、文章を自動修正しますか？というメッセージボックスが出てくるので、
ここで自動修正したいときは「はい」を押します。
不要な時は「いいえ」を押します。
⑥自動修正に「はい」を押した場合、以下のようになります。
※ファイル名の最後に「_修正版」がつく
⑦フォルダを確認すると、別名保存したファイルもちゃんと作られていることが確認できます。
処理時間とコストの比較
処理時間
| 方法 | 50ファイル処理時間 | 効率 |
|---|---|---|
| 手動（Copilot使用） | 約60分 | 1ファイル1.2分 |
| このVBAツール | 約5分 | 1ファイル6秒 |
削減時間：55分（約92%削減）
コスト比較
| 項目 | Copilot | このツール |
|---|---|---|
| 月額料金 | $30/ユーザー | なし |
| API料金 | なし | $0.01/ファイル |
| 50ファイル処理 | $30 | $0.50 |
コスト削減：$29.50（約98%削減）
コード解説：会社独自ルールとプロンプト作成
会社独自ルールの定義をしているコード
Private Function GetCompanyRules() As CompanyRules
Dim rules As CompanyRules
rules.禁止表現 = "「弊社」「〜の方」「〜させて頂く」「宜しく」「致します」"
rules.推奨表現 = "「弊社」→「当社」、「お客様」→「お取引先様」"
rules.必須トーン = "です・ます調で統一。丁寧かつ簡潔に。"
rules.その他ルール = "文章は3行以内を推奨、数値には単位を明記"
GetCompanyRules = rules
End Function
4つのカテゴリでルールを管理
禁止表現 - 使ってはいけない言葉
推奨表現 - 代わりに使うべき言葉（置き換えルール）
必須トーン - 文体の統一（です・ます調 / だ・である調）
その他ルール - 細かい指定（文字数、単位表記など）
カスタマイズ例（営業部向け）
vbarules.禁止表現 = "「安い」「高い」「すごい」"
rules.推奨表現 = "「安い」→「コストパフォーマンスに優れた」"
rules.必須トーン = "です・ます調、前向きな表現"
rules.その他ルール = "数値には根拠を示す、顧客メリットを明確に"
ここで会社独自の表現などを指定することができます。
プロンプ作成をしているコードとその仕組み
Private Function CreateReviewPrompt(docText As String, rules As CompanyRules) As String
Dim prompt As String
' 長い文書は2000文字に制限（API制限・コスト対策）
If Len(docText) > 2000 Then
textSample = Left(docText, 2000) & "...(以下省略)"
Else
textSample = docText
End If
' プロンプトを3つのセクションで構成
prompt = "以下のビジネス文書を会社の文書作成基準に基づいてレビューしてください。" & vbLf & vbLf
' セクション1: 会社基準を明示
prompt = prompt & "【会社の文書作成基準】" & vbLf
prompt = prompt & "1. 禁止表現: " & rules.禁止表現 & vbLf
prompt = prompt & "2. 推奨表現: " & rules.推奨表現 & vbLf
prompt = prompt & "3. 必須トーン: " & rules.必須トーン & vbLf
prompt = prompt & "4. その他ルール: " & rules.その他ルール & vbLf & vbLf
' セクション2: JSON出力形式を具体例で指定
prompt = prompt & "【重要】以下の形式で必ずJSON形式のみで出力してください：" & vbLf
prompt = prompt & "{""総合評価"":""OK"",""NG項目数"":0,""指摘事項"":""問題なし"",""改善提案"":""修正不要""}" & vbLf & vbLf
' セクション3: 対象文書
prompt = prompt & "【対象文書】" & vbLf & textSample
CreateReviewPrompt = prompt
End Function
プロンプト設計の3つのポイント
- 明確な指示 - 「会社の文書作成基準に基づいて」と明示
- 構造化 - 番号付きリストで整理してAIが理解しやすく
- 出力形式の具体例 - JSON形式を例示してパースエラーを防止
完成したプロンプトのイメージ
以下のビジネス文書を会社の文書作成基準に基づいてレビューしてください。
【会社の文書作成基準】
1. 禁止表現: 「弊社」「〜の方」「〜させて頂く」
2. 推奨表現: 「弊社」→「当社」
3. 必須トーン: です・ます調で統一
4. その他ルール: 文章は3行以内、数値に単位明記
【重要】以下の形式で必ずJSON形式のみで出力してください：
{"総合評価":"OK","NG項目数":0,"指摘事項":"問題なし","改善提案":"修正不要"}
【対象文書】
お世話になります。営業部の佐藤です。
今月の売上の方につきまして、ご報告させて頂きます。
弊社の営業活動におきましては...
この設計により以下の点が可能になります。
- 会社独自のルールを厳密に適用
- VBAで解析しやすいJSON形式で返却
- Copilotではできないカスタマイズを実現
カスタマイズ例
ここからは、カスタマイズの例をいくつか挙げていきます。
1. ルールの外部ファイル化
' rules.jsonファイルから読み込み
Private Function LoadCompanyRulesFromFile() As CompanyRules
Dim jsonText As String
Dim filePath As String
filePath = ThisWorkbook.Path & "\rules.json"
' JSONファイル読み込み
Open filePath For Input As #1
jsonText = Input$(LOF(1), #1)
Close #1
' JSONをパースしてルールに変換
' （実装省略）
End Function
rules.json の例：
{
"禁止表現": ["弊社", "〜の方", "〜させて頂く"],
"推奨表現": {
"弊社": "当社",
"お客様": "お取引先様"
},
"必須トーン": "です・ます調",
"その他ルール": [
"文章は3行以内",
"専門用語には説明を付ける"
]
}
2. 部署別ルールの適用
' ファイル名から部署を判定してルールを切り替え
If InStr(fileName, "営業部") > 0 Then
rules = Get営業部Rules()
ElseIf InStr(fileName, "技術部") > 0 Then
rules = Get技術部Rules()
Else
rules = Get共通Rules()
End If
3. レポートの自動メール送信
' 処理完了後にTeamsやメールで通知
Call SendReportByEmail("manager@company.com", ws)
応用例
1. 定期実行（夜間バッチ）
Windowsタスクスケジューラと組み合わせ：
' 自動実行用のマクロ
Sub 自動実行_Word文書レビュー()
' 固定フォルダを処理
Const TARGET_FOLDER As String = "C:\Reports\Daily\"
' ログ記録
Call WriteLog("処理開始: " & Now)
' 処理実行
Call Word文書を一括レビュー_自動(TARGET_FOLDER)
' ログ記録
Call WriteLog("処理完了: " & Now)
End Sub
設定方法：
- タスクスケジューラを開く
- 基本タスクの作成
- Excel.exeで該当ファイルを開く
- マクロ自動実行設定
2. SharePoint連携
' SharePointのドキュメントライブラリから取得
folderPath = "https://company.sharepoint.com/sites/reports/Documents"
3. 差分レビュー
' 前回レビュー結果と比較
If 今回NG項目数 < 前回NG項目数 Then
評価 = "改善"
ElseIf 今回NG項目数 > 前回NG項目数 Then
評価 = "悪化"
Else
評価 = "変化なし"
End If
・・・などのこともできます。
トラブルシューティング
Q1: 処理が遅い
A: 以下を確認してください
- Wordアプリケーションを再利用しているか
- 不要なWordインスタンスが残っていないか
- API_ENDPOINTが正しいか
' 確認方法：タスクマネージャーでWINWORD.EXEを確認
' 解決方法：全Wordインスタンスを閉じる
Sub Word終了()
Dim wordApp As Object
Set wordApp = GetObject(, "Word.Application")
wordApp.Quit
End Sub
Q2: APIエラーが出る
A: レート制限の可能性
- GPT-4o-miniは1分間に60リクエストまで
- 大量処理の場合は適度に待機時間を入れる
' 10ファイルごとに5秒待機
If i Mod 10 = 0 Then
Application.Wait Now + TimeValue("00:00:05")
End If
Q3: 日本語が文字化けする
A: Wordファイルのエンコーディング確認
- UTF-8で保存されているか確認
- VBAコード自体もUTF-8で保存
まとめ
VBAと生成AIを組み合わせることで、Copilotではできない大量文書の自動レビューを実現しました。
このツールの強み
| 項目 | 内容 |
|---|---|
| 一括処理 | 50ファイルを約5分で自動処理 |
| 独自ルール | 会社基準を完全実装 |
| コスト削減 | Copilotの約98%削減 |
| 時間削減 | 手動の約92%削減 |
| 品質向上 | 一貫した基準で評価 |
| 監査証跡 | 全処理ログを記録 |
実務での効果
あくまでも想定ですが、だいたいこのようなコスト削減が期待できます。
- 月末の報告書レビュー：60分 → 5分
- 月間コスト：$30 → $0.50
- 品質の標準化：主観的評価 → 客観的評価
- 継続的改善：履歴データで傾向分析
初級編からのステップアップ
| 項目 | 初級編 | 中級編 |
|---|---|---|
| 処理対象 | Excel単一セル | Word複数ファイル |
| ファイル操作 | なし | フォルダ走査、ファイル読み込み |
| ルール | 汎用プロンプト | 会社独自ルール実装 |
| 結果管理 | 隣セルに出力 | Excel一覧レポート |
| エラー処理 | 基本 | 詳細ログ、リトライ |
次回予告
本記事では大量Word文書の一括レビューを実現しましたが、さらに高度な実装も可能です。
次回「上級編」では以下の機能を追加します：
- Power Automate連携 - SharePoint監視→自動レビュー
- 承認ワークフロー - レビュー結果に応じた自動承認
- 監査ログ・統計 - 処理履歴の完全記録
- Teams通知 - 処理完了を自動通知
- Power BIダッシュボード - 文書品質の可視化
「VBA×Power Automate×生成AIで作る企業向け文書管理システム」
続編記事もぜひご覧ください。記事がアップされたら、こちらも読んでいただけると嬉しいです！
この記事が役に立ったら、ぜひ LGTM をお願いします 👍
ご質問やフィードバックもお気軽にコメント欄へどうぞ！