はじめに

前回の初級編では、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 をお願いします 👍
ご質問やフィードバックもお気軽にコメント欄へどうぞ！

参考資料