ワード中の誤字脱字をチェックしてエクセルに出力するマクロ【図解】

このマクロは、ワードのチェック機能（スペルチェックと文章校正）を使ってワード文書中の誤字脱字をエクセルファイルに出力して一覧にするマクロ（Word VBA）です。

ワードの標準機能である「スペルチェックと文章校正」は便利な機能ですが、誤字脱字が疑われる箇所をいちいち１つ１つチェックするのは面倒です。

このマクロを使用すると、ワード文書中で誤字脱字が疑われる箇所が一覧になってエクセルファイルに出力されるため、誤字脱字箇所を集中的にチェックすることが可能になります。

\Word VBAを学べる貴重な一冊 /

概要

このマクロの概要を以下にイラストで示します。

マクロの全体の流れ

step
1各自のワードファイルを開きます

step
2ワード文書の左上に表示される本マクロのアイコンをクリックします

（アイコンの種類は各自が選べます。詳細は、後述の「マクロの使用準備」をご参照ください）

step
3モードを選択します

以下の入力ボックスが出ます。

モード選択については後述します。

モード番号を入力後に「OK」ボタンを押します。

確認メッセージがでるので、「はい」を選択します。

「はい」を選択すると、誤字脱字が疑われる箇所の自動収集が始まります。

処理中はワード文書の左下に、以下のように進行状況が表示されます。

処理が終了すると、以下のようなエクセルファイルが開きます。

このエクセルファイルはデスクトップ上に保存されています。

ファイル名は、「○○_誤字脱字_モード_YYYYMMDDHHMMSS.xlsx」という形式になります。

〇〇はチェック対象のワードファイルの名前です。

例えば、テスト.docxで本マクロを実行すると、テスト_誤字脱字一覧_スペル + 文法_20241004114657.xlsxという名前のエクセルファイルが出力されます。

ファイル名の末尾はHHMMSS（HH時MM分SS秒）となるため、既存のファイルが上書きされることはありません。

以上が全体の流れです！

マクロの詳細な説明

本マクロの処理モード

本マクロには、以下の３つのモードがあります。

１：スペルチェック

２：文法チェック

３：スペルチェック＋文法チェック

いずれのモードも、ワードの標準機能の「スペルチェックと文章校正」を使用します。

１：スペルチェック

半角英語のスペルミスが疑われる箇所を検出します。

ワード文書中で半角英字に赤線が引かれる箇所が検出されます。

例えば、以下のような箇所が検出されます。

半角英字がほぼ存在しない日本語メインの全角文字列のワード文書では、検出されることは稀なはずです。

英語のワードファイルでは、スペルミスの発見に有効です。

但し、マイナーな地名や独特の略語などもスペルミスとして検出されるため、ざっと見た感じで赤線部が多いワードファイルでは処理に時間がかかります。

そうしたものや、数百ページのワード文書をチェックしたい場合は、処理時間の長時間化をさけるために、ワード文書を分割後に本マクロを適用することをご検討ください。

ワード文書の分割には、以下のマクロが便利です。

指定ページ数単位でワード文書を簡単に分割するマクロ【図解】

こんな方におすすめ ワード文書を任意のページ数単位で複数のワード文書に分割したい このマクロは、指定ページ数単位でワード文書を簡単に分割するマクロ（Word VBA）です。 このマクロを実行すると、以 ...

２：文法チェック

文法的な間違いが疑われる箇所を検出します。

ワード文書中で赤線（主に全角文字列）と青線（主に半角文字列）が引かれる箇所が検出されます。

（表記ゆれは検出されません）

例えば、以下のような間違い箇所が検出されます。

（上記の英文では、半角スペースが連続して２つ存在するために文法ミスとして青線が引かれています）

このモードも、ページ数や誤字脱字箇所の多さに応じて処理時間がかかる場合があります。

場合によっては、ワード文書を分割することをご検討ください。

ワード文書の分割には、上に紹介した記事のマクロが便利です。

３：スペルチェック＋文法チェック

モード３では、スペルチェックと文法チェックを連続して行います。

各チェックの結果は、各チェックを独立して実施した場合と同じです。

このモードは３つのモード中で一番時間がかかります。

そのため、最初にモード１とモード２を実施し、許容できる処理時間であることを確認してから行うようにしてください

場合によっては、ワード文書の分割をご検討ください。

ワード文書の分割には、上に紹介した記事のマクロが便利です。

結果のエクセルファイル

結果のエクセルファイルの内容は以下のような感じです。

各列ごとに説明します。

番号

「番号」は、誤字脱字が疑われる箇所の連番を示します。

モード１とモード２では、この番号は、誤字脱字が疑われる箇所のワード文書での登場順序に対応します。

ページと行数

「ページ」と「行数」は、誤字脱字が疑われる箇所（後述の「誤字脱字」列）を含むパラグラフの最初の１文字が何ページ目の何行目にあるかを示します（「誤字脱字」そのものの位置ではないことにご注意ください）。

頻度

「頻度」は、誤字脱字が疑われる箇所がその文書の中で何回登場するかを示します。

種別

スペルチェックで検出されたものは、「種別」が「スペル」と表示されます。

文法チェックで検出されたものは、「種別」が「文法」になります。

誤字脱字

「誤字脱字」は、誤字脱字が疑われる文字列です。

「種別」が「スペル」の「誤字脱字」は、ワードの標準機能で認識されるスペルミスそのものです。

「種別」が「文法」の「誤字脱字」は、本マクロのアルゴリズムで特定されたものです。

アルゴリズムを使用している理由は、Word標準機能では文法チェックでヒットする単位がパラグラフ単位であり、その中のどの部分が問題なのかを標準機能では特定できないためです。

本マクロのアルゴリズムでは、ヒットパラグラフ単位を左右から削っていき、文法チェックでのエラーがでなくなった位置を手掛かりに「誤字脱字」を特定しています。

そのため、稀に、誤字脱字が疑われる箇所と少しずれた箇所が「誤字脱字」として特定されてしまうことがあります。

より正確には、後述の「リンク２」からワード文書中の該当部分へジャンプして確認してください。

周辺文字列

「周辺文字列」は、「誤字脱字」にその左右の文字列を含めたものです。

「誤字脱字」の左側と右側の文字数を何文字まで表示させるかは、後述の本マクロのコードの中の以下の赤線部で任意の値（0以上の整数）を設定できます。

この値は、最大数です。

デフォルト値は５０です。

０を設定すると、「誤字脱字」左右の表示文字数が０になり、結果的に周辺文字列の列は「誤字脱字」のみになります。

但し、「誤字脱字」でも説明しましたように、種別が「文法」の「誤字脱字」は、本マクロのアルゴリズムで特定していることから、たまに、本来の箇所と少しずれた箇所が「誤字脱字」として特定されることがあるため、０を設定することは推奨されません。

同じ問題パラグラフ中に「誤字脱字」が複数存在する場合は、一番左に位置する「誤字脱字」の左側と一番右に位置するの「誤字脱字」の右側にこの最大文字数設定値が適用されます。

デフォルト値は５０ですが、日本語の文書では２０～３０くらいでもいいかもしれません。

好みに合わせて設定してください。

設定値が５０の場合は、以下のような感じになります。

「誤字脱字」の左右の文字列の文字数が最大設定値以下の場合は、削られることなくそのままの数の文字数が表示されます。

リンク１とリンク２

リンク１をクリックすると、H列の「誤字脱字」の文字列を検索キーとして出力元ワードファイルにジャンプします。

そのため、「誤字脱字」の文字列がワード文書中に複数存在する場合（「頻度」の列の数が２以上の場合）は、常にワード文書中の最初のヒット部にジャンプしてしまいます。

リンク２をクリックすると、I列の「周辺文字列」の一部を検索キーとして出力元ワードファイルにジャンプするため、リンク２の方が精度が高いです。

これらのリンクがマクロで作成できなかった場合は「利用不可」と表示されます。

「誤字脱字」にタブが含まれている場合などは、リンクが機能しないこともあります。

補足説明

チェック対象のワード文書について

本マクロとは無関係に、一般的に、新たに入手／コピーしたワードファイルを開くと、以下のように「編集を有効にする」というボタンが表示される場合があります。

本マクロは、チェック対象のワードファイルを変更するものではありませんが、本マクロが動作するには「編集を有効にする」を押す必要があります。

また、本マクロはチェック対象のワードファイルを変更するものではありませんが、念のためワードファイルの事前バックアップをお願いします。

チェック開始時に稀に表示されるメッセージについて

本マクロを使用して処理を開始すると、以下のようなメッセージが出る場合があります。

このメッセージは、本マクロが出しているものではなく、本マクロがワードの標準チェック機能を呼び出したときに表示されるものです。

手動で「スペルチェックと文章校正」を行った場合でも表示されるものです。

この例のメッセージの意味は、「○○語（この例では、ワードがスペイン語と判断する文字列）がワード文書中にありますが、その校正ツールはインストールされていません」というお知らせです。

この場合は、OKボタンを教えて下さい。

処理は続行されます。

通常、チェック対象としたい言語は英語と日本語だと思いますが、

本当にスペイン語がメインの文書をチェックしたい場合は、スペイン語（またはチェックしたい他の言語）の校正ツールをインストールするとよいと思います。

テストはしていませんが、おそらく出力エクセルに誤字脱字箇所が入ってくると思います。

マクロの準備

以下の手順を行うことで、各自のワードファイルから本マクロを簡単に呼び出せるようになります。

１．こちらの記事に記載したステップ①の手順０～６までを実施した後、ステップ①の手順７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。

２．こちらの記事に記載したステップ①の８から２２を行います

（ステップ①の１１では、以下のマクロ名を選択してから、追加ボタンを押してください）

Project.Module1.ExportTyposToExcel

ステップ①の１１で追加するのは、上記のマクロ名のみです。

（ステップ①の１３では、お好きなアイコンを選んでください）

（ステップ①の２０での保存名は何でもかまいません）

（ステップ①の２２の次に記載されている「動作確認」はスキップしていただいてかまいません）

３．こちらの記事に記載したステップ②を行います

ステップ②を行うことで、このマクロをどのワード文書からも呼び出せるようになります。

（このステップ②を行うと、各自のワードファイルを開いた際に、各自が選んだマクロアイコンがワード文書の左上に表示されるようになります）

以上で、マクロを使用する準備が整いました！

マクロの削除

本マクロが不要になった場合は、こちらの手順でdotmファイルごと削除してください。

マクロのコード

以下は、本マクロのコードです。

上の説明にあるように標準モジュールにコピペしてご使用ください。

（以下のコードをすべて選択して、そのまま貼り付けてください）

現在の公開バージョンは、V01L01（公開日：2024/10/04）です。

Sub ExportTyposToExcel()
' V01L01
    Dim doc As Document
    Dim rng As Range
    Dim errCount As Long
    Dim errText As String
    Dim errPage As Long
    Dim excelApp As Object
    Dim workbook As Object
    Dim worksheet As Object
    Dim desktopPath As String
    Dim fileName As String
    Dim baseName As String
    Dim extCount As Long
    Dim fullPath As String
    Dim typoLine As String
    Dim contextLength As Long
    Dim spellingErrors As ProofreadingErrors
    Dim grammarErrors As ProofreadingErrors
    Dim pageInfo As Variant
    Dim lineInfo As Variant
    Dim errFrequency As Long
    Dim typoDict As Object
    Dim typoCounterForSpellingErrors As Long
    Dim typoCounterForGrammarErrors As Long
    Dim linkAddress1 As String
    Dim linkAddress2 As String
    Dim inputBoxValue As Variant
    Dim totalSpellingErrors As Long
    Dim totalGrammarErrors As Long
    Dim currentDate As String
    Dim OutputModeMessage As String
    Dim msgBoxValue As Integer
    Dim spellCell As Object
    Dim GrammaticalErrorText As String
    Dim iForTotal As Integer
    Dim totalPages As Long
    Dim uncPath As String
    Dim typoLineForSearch As String
    Dim link2ErrFlgForSpelErr As Boolean
    Dim hasSpecialChars As Boolean
    Dim dt As Date

    ' 未保存の変更をチェック
    If ActiveDocument.Saved = False Then
        MsgBox "このドキュメントには未保存の変更があります。" _
        & vbCrLf & "保存後に再度処理を実行してください。", vbInformation, "未保存の変更あり"
        Exit Sub
    End If

    ' ★「誤字脱字」の前後の文字列を最大何文字表示するかを半角整数で指定してください★
    ' 　デフォルト値は50です。
    contextLength = 50

    ' 最終ページの取得
    totalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)

    Do
        '入力ボックスの表示
        inputBoxValue = InputBox _
        ("モードを数字（半角でも全角でも可）で入力してください" _
         & vbCrLf & vbCrLf & "1：スペルチェック" _
         & vbCrLf & vbCrLf & "2：文法チェック" _
         & vbCrLf & vbCrLf & "3：スペルチェック+文法チェック" _
         & vbCrLf & vbCrLf & "このワード文書のページ数：" & totalPages _
         & vbCrLf, "モード選択")
      
        'キャンセルの場合は終了
        If StrPtr(inputBoxValue) = 0 Then
            Exit Sub
        ElseIf inputBoxValue = "" Then
            MsgBox "数字を入力してください"
        ElseIf inputBoxValue <> "" Then
            Exit Do
        End If
    Loop

    If inputBoxValue <> 1 And inputBoxValue <> 2 And inputBoxValue <> 3 Then
        MsgBox "無効な入力値です。1～3の整数を入力してください。", vbCritical, "エラー"
        Exit Sub
    End If

    Select Case inputBoxValue
        Case 1
            OutputModeMessage = "スペルチェックを開始します" _
            & vbCrLf & "よろしいですか？"
        Case 2
            OutputModeMessage = "文法チェックを開始します" _
            & vbCrLf & "よろしいですか？"
        Case 3
            OutputModeMessage = "スペルチェック + 文法チェックを開始します" _
            & vbCrLf & "よろしいですか？"
    End Select

    msgBoxValue = MsgBox(OutputModeMessage, vbYesNo + vbQuestion + vbDefaultButton2, "確認")

    If msgBoxValue = vbNo Then Exit Sub

    ' 現在のドキュメントを設定
    Set doc = ActiveDocument

    ' ドキュメントが保存されていない場合、保存を促す
    If doc.Path = "" Then
        MsgBox "ドキュメントが保存されていません。まずドキュメントを保存してください。"
        Exit Sub
    End If

    Application.StatusBar = "処理を開始しました"

    ' ドキュメントのフルパスをUNCパスで取得
    uncPath = ConvertToUNC(doc)
    
    hasSpecialChars = (InStr(uncPath, "[") > 0) Or (InStr(uncPath, "]") > 0)
    
    If hasSpecialChars = True Then
         MsgBox "このワードファイルのファイル名には、 [ または ] が使用されています。ファイルの名前を変更してから再度実行してください"
         Set doc = Nothing
         Exit Sub
    End If

    ' デスクトップのパス取得
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    ' ドキュメント名から拡張子を除去し、ベースファイル名を設定
    baseName = Left(doc.Name, InStrRev(doc.Name, ".") - 1) & "_誤字脱字一覧"
    
    ' モード名を付与
    Select Case inputBoxValue
        Case 1
            baseName = baseName & "_スペル"
        Case 2
            baseName = baseName & "_文法"
        Case 3
            baseName = baseName & "_スペル + 文法"
    End Select
    
    dt = Now
    
    fileName = baseName & "_" & Year(dt) & Right("0" & Month(dt), 2) & Right("0" & Day(dt), 2) _
    & Right("0" & Hour(dt), 2) & Right("0" & Minute(dt), 2) & Right("0" & Second(dt), 2) & ".xlsx"

    fullPath = desktopPath & "\" & fileName

    ' 誤字脱字の総数を取得
    Select Case inputBoxValue
        Case 1
            Set spellingErrors = doc.spellingErrors
            Application.StatusBar = "スペルチェック箇所の総数を取得しています"
            totalSpellingErrors = spellingErrors.count
        Case 2
            Set grammarErrors = doc.GrammaticalErrors
            Application.StatusBar = "文法チェック箇所の総数を取得しています"
            totalGrammarErrors = grammarErrors.count
        Case 3
            Set spellingErrors = doc.spellingErrors
            Set grammarErrors = doc.GrammaticalErrors
            Application.StatusBar = "スペルチェック箇所の総数を取得しています"
            totalSpellingErrors = spellingErrors.count
            Application.StatusBar = "文法チェック箇所の総数を取得しています"
            totalGrammarErrors = grammarErrors.count
    End Select
    
    DoEvents
    
    Select Case inputBoxValue
        Case 1
            If totalSpellingErrors = 0 Then
                MsgBox "スペルミスが疑われる箇所はありません。"
                Exit Sub
            End If
        Case 2
            If totalGrammarErrors = 0 Then
                MsgBox "文法ミスが疑われる箇所はありません。"
                Exit Sub
            End If
        Case 3
            If totalSpellingErrors + totalGrammarErrors = 0 Then
                MsgBox "誤字脱字が疑われる箇所はありません。"
                Exit Sub
            End If
    End Select

    ' 誤字脱字をカウントするためのDictionaryを用意
    Set typoDict = CreateObject("Scripting.Dictionary")
    
    ' 再度各誤字脱字総数を代入（総数が正確に反映されないバグ防止）
    Application.StatusBar = "誤字脱字総数をセットしています"
    For iForTotal = 1 To 10
        Select Case inputBoxValue
            Case 1
                totalSpellingErrors = spellingErrors.count
            Case 2
                totalGrammarErrors = grammarErrors.count
            Case 3
                totalSpellingErrors = spellingErrors.count
                totalGrammarErrors = grammarErrors.count
        End Select
    Next iForTotal

    typoCounterForSpellingErrors = 0
    typoCounterForGrammarErrors = 0

    If inputBoxValue = 1 Or inputBoxValue = 3 Then
        ' スペルチェックを実行して要チェック箇所を辞書に追加
        For Each rng In spellingErrors
            errText = rng.Text
            typoCounterForSpellingErrors = typoCounterForSpellingErrors + 1
            
            DoEvents
            Application.StatusBar = "スペルチェック箇所を集めています（" _
            & typoCounterForSpellingErrors & "/" & totalSpellingErrors & "）"
            
            If typoDict.Exists(errText) Then
                typoDict(errText) = typoDict(errText) + 1
            Else
                typoDict.Add errText, 1
            End If
        Next rng
    End If

    If inputBoxValue = 2 Or inputBoxValue = 3 Then
        ' 文法チェックを実行して要チェック箇所を辞書に追加
        For Each rng In grammarErrors
            errText = rng.Text
            typoCounterForGrammarErrors = typoCounterForGrammarErrors + 1
            
            DoEvents
            Application.StatusBar = "文法チェック箇所を集めています（" _
            & typoCounterForGrammarErrors & "/" & totalGrammarErrors & "）"
                
            If typoDict.Exists(errText) Then
                typoDict(errText) = typoDict(errText) + 1
            Else
                typoDict.Add errText, 1
            End If
        Next rng
    End If

    Application.StatusBar = "エクセルファイルの準備をしています"

    ' Excelアプリケーションを起動
    Set excelApp = CreateObject("Excel.Application")
    Set workbook = excelApp.Workbooks.Add
    Set worksheet = workbook.Sheets(1)

    ' シートのヘッダを設定
    worksheet.Cells(1, 1).Value = "番号"
    worksheet.Cells(1, 2).Value = "ページ"
    worksheet.Cells(1, 3).Value = "行数"
    worksheet.Cells(1, 4).Value = "頻度"
    worksheet.Cells(1, 5).Value = "リンク1"
    worksheet.Cells(1, 6).Value = "リンク2"
    worksheet.Cells(1, 7).Value = "種別"
    worksheet.Cells(1, 8).Value = "誤字脱字"
    worksheet.Cells(1, 9).Value = "周辺文字列"

    errCount = 2

    If inputBoxValue = 1 Or inputBoxValue = 3 Then
        ' スペルチェックをエクスポート
        For Each rng In spellingErrors

            DoEvents
            Application.StatusBar = "処理中: " & errCount - 1 & " / " & _
            totalSpellingErrors & " のスペルチェック箇所を処理しています"
   
            ' ページと行の情報を取得
            pageInfo = GetFirstCharacterPageNumber(rng)
            lineInfo = rng.Information(wdFirstCharacterLineNumber)

            ' 誤字脱字を取得
            errText = rng.Text

            errFrequency = typoDict(errText)
            
            typoLine = rng.Paragraphs(1).Range.Text
            
            ' お尻の改行を削る
            If Right(typoLine, 1) = vbCrLf Or Right(typoLine, 1) = vbCr Or Right(typoLine, 1) = vbLf Then
                typoLine = Left(typoLine, Len(typoLine) - 1)
            End If
    
            ' typoLineの左右のトリミング
            If InStr(typoLine, errText) > contextLength + 1 Then
                typoLine = Right(typoLine, Len(typoLine) - (InStr(typoLine, errText) - contextLength - 1))
            End If
            If Len(typoLine) - (InStrRev(typoLine, errText) + Len(errText)) > contextLength Then
                typoLine = Left(typoLine, InStrRev(typoLine, errText) + Len(errText) + contextLength - 1)
            End If

            ' リンク１の作成（誤字脱字のみを検索キーとする）
            linkAddress1 = uncPath & "#" & errText
            
            ' リンク２の作成（誤字脱字を含む１行を検索キーとする）
            typoLineForSearch = typoLine
            ' 左右の不要文字をカット
            typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, Chr(7))
            typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, vbTab)
            typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, vbCr)
            typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, vbLf)
            ' 120字以上は右側をカット
            If Len(typoLineForSearch) > 120 Then
                typoLineForSearch = Left(typoLineForSearch, 120)
            End If
                
            With worksheet
                .Cells(errCount, 1).Value = errCount - 1
                .Cells(errCount, 2).Value = pageInfo
                .Cells(errCount, 3).Value = lineInfo
                .Cells(errCount, 4).Value = errFrequency
                
                ' リンク１の処理
                On Error Resume Next
                    .Cells(errCount, 5).Formula = "=HYPERLINK(""" & linkAddress1 & """, ""リンク１"")"
                    If Err.Number <> 0 Then
                        .Cells(errCount, 5).Value = "利用不可"
                    End If
                On Error GoTo 0
                
                ' リンク2の処理
                Dim originalLink2 As String
                originalLink2 = typoLineForSearch
                
                link2ErrFlgForSpelErr = True
                
                ' リンクに使用できない文字列に備える
                ' エラーが出た場合は右から削る
                Do While Len(typoLineForSearch) >= 10
                    On Error Resume Next
                    .Cells(errCount, 6).Formula = "=HYPERLINK(""" & uncPath & "#" & typoLineForSearch & """, ""リンク２"")"
                    If Err.Number = 0 Then
                        link2ErrFlgForSpelErr = False
                        Exit Do
                    End If
                    On Error GoTo 0
                    typoLineForSearch = Left(typoLineForSearch, Len(typoLineForSearch) - 1)
                Loop
                
                ' まだエラーがある場合は左から削る
                If link2ErrFlgForSpelErr = True Then
                    typoLineForSearch = originalLink2
                    Do While Len(typoLineForSearch) >= 10
                        On Error Resume Next
                        .Cells(errCount, 6).Formula = "=HYPERLINK(""" & uncPath & "#" & typoLineForSearch & """, ""リンク２"")"
                        If Err.Number = 0 Then
                            Exit Do
                        End If
                        On Error GoTo 0
                        typoLineForSearch = Right(typoLineForSearch, Len(typoLineForSearch) - 1)
                    Loop
                End If
                
                On Error Resume Next
                    .Cells(errCount, 6).Formula = "=HYPERLINK(""" & uncPath & "#" & typoLineForSearch & """, ""リンク２"")"
                    If Err.Number <> 0 Then
                        .Cells(errCount, 6).Value = "利用不可"
                    End If
                On Error GoTo 0
                
                .Cells(errCount, 7).Value = "スペル"
                .Cells(errCount, 8).Value = "'" & errText
                .Cells(errCount, 8).Font.Color = RGB(255, 0, 0)
                .Cells(errCount, 8).Font.Bold = True
                .Cells(errCount, 9).Value = "'" & typoLine
            End With
            
            ' スペルミスのハイライト処理
            Set spellCell = worksheet.Cells(errCount, 9)

            ' spellCell.Valueに複数のerrTextが含まれている場合、順次処理
            Dim errPosInCell As Long
            errPosInCell = InStr(1, spellCell.Value, errText)
            Do While errPosInCell > 0
                With spellCell.Characters(Start:=errPosInCell, Length:=Len(errText)).Font
                    .Color = RGB(255, 0, 0) ' 赤色
                    .Bold = True ' 太字
                End With
                ' 次のerrTextを探す
                errPosInCell = InStr(errPosInCell + Len(errText), spellCell.Value, errText)
            Loop

            errCount = errCount + 1
        Next rng
    End If

    errCount = 2

    If inputBoxValue = 2 Or inputBoxValue = 3 Then
        ' 文法チェックをエクスポート
        For Each rng In grammarErrors
        
            DoEvents
            
            ' ページと行の情報を取得
            pageInfo = GetFirstCharacterPageNumber(rng)
            lineInfo = rng.Information(wdFirstCharacterLineNumber)
    
            ' 誤字脱字を含むテキスト
            errText = rng.Text
            
            ' 頻度を取得
            errFrequency = typoDict(errText)
            
            ' アルゴリズムで文法的な誤字脱字を取得
            Application.ScreenUpdating = False
            GrammaticalErrorText = GetGrammaticalErrorText(errText)
            Application.ScreenUpdating = True
                        
            Application.StatusBar = "処理中: " & errCount - 1 & " / " & _
            totalGrammarErrors & " の文法チェック箇所を処理しています"
                        
                        
            ' GrammaticalErrorTextの左右のトリミング
            If InStr(errText, GrammaticalErrorText) > contextLength + 1 Then
                errText = Right(errText, Len(errText) - (InStr(errText, GrammaticalErrorText) - contextLength - 1))
            End If
            If Len(errText) - (InStrRev(errText, GrammaticalErrorText) + Len(GrammaticalErrorText)) > contextLength Then
                errText = Left(errText, InStrRev(errText, GrammaticalErrorText) + Len(GrammaticalErrorText) + contextLength - 1)
            End If
                       
            ' リンク１の作成
            linkAddress1 = uncPath & "#" & GrammaticalErrorText
            
            ' リンク２の作成
            ' 左右の不要文字の除去
            typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(errText, GrammaticalErrorText, Chr(7))
            typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(errText, GrammaticalErrorText, vbTab)

            ' 120超はカット
            If Len(typoLineForSearch) > 120 Then
                linkAddress2 = uncPath & "#" & Left(typoLineForSearch, 120)
            Else
                linkAddress2 = uncPath & "#" & typoLineForSearch
            End If
                                        
            With worksheet
                .Cells(errCount + totalSpellingErrors, 1).Value = errCount + totalSpellingErrors - 1
                .Cells(errCount + totalSpellingErrors, 2).Value = pageInfo
                .Cells(errCount + totalSpellingErrors, 3).Value = lineInfo
                .Cells(errCount + totalSpellingErrors, 4).Value = errFrequency
                
                On Error Resume Next
                    .Cells(errCount + totalSpellingErrors, 5).Formula = "=HYPERLINK(""" & linkAddress1 & """, ""リンク１"")"
                    If Err.Number <> 0 Then
                        .Cells(errCount + totalSpellingErrors, 5).Value = "利用不可"
                    End If
                On Error GoTo 0
                
                On Error Resume Next
                    .Cells(errCount + totalSpellingErrors, 6).Formula = "=HYPERLINK(""" & linkAddress2 & """, ""リンク２"")"
                    If Err.Number <> 0 Then
                        .Cells(errCount + totalSpellingErrors, 6).Value = "利用不可"
                    End If
                On Error GoTo 0
                
                .Cells(errCount + totalSpellingErrors, 7).Value = "文法"
                .Cells(errCount + totalSpellingErrors, 8).Value = "'" & GrammaticalErrorText
                .Cells(errCount + totalSpellingErrors, 8).Font.Color = RGB(255, 0, 0)
                .Cells(errCount + totalSpellingErrors, 8).Font.Bold = True
                .Cells(errCount + totalSpellingErrors, 9).Value = "'" & errText
            End With

            ' スペルミスのハイライト処理
            Set spellCell = worksheet.Cells(errCount + totalSpellingErrors, 9)
            With spellCell.Characters(Start:=InStr(1, errText, GrammaticalErrorText), _
            Length:=Len(GrammaticalErrorText)).Font
                    .Color = RGB(255, 0, 0) ' 赤色
                    .Bold = True ' 太字
            End With
                                     
            errCount = errCount + 1
        Next rng
    End If
    
    currentDate = Format(Now, "yyyy年mm月dd日 hh時nn分")
    worksheet.Name = currentDate
    
    workbook.SaveAs fullPath

    Application.StatusBar = "終了処理をしています"

    Set worksheet = Nothing
    Set workbook = Nothing
    Set spellingErrors = Nothing
    Set grammarErrors = Nothing
    Set rng = Nothing
    Set doc = Nothing
    Set typoDict = Nothing
    
    ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
    excelApp.Visible = True
    Documents.Open fileName:=uncPath
    
    Application.StatusBar = "処理が終了しました！" & "　　出力エクセルファイルはデスクトップに保存されています"
    
End Sub

Function GetGrammaticalErrorText(inputText As String) As String
    Dim errorRange As Range
    Dim startPos As Long, endPos As Long
    Dim rightPos As Long, leftPos As Long
    Dim errorText As String, testText As String
    Dim containsError As Boolean
    Dim i As Long, step As Long
    Dim leftCounter As Long
    Dim tempDoc As Document
    Dim stepSearch1 As Integer
    Dim stepSearch2 As Integer
    Dim stepSearch3 As Integer
        
    Set tempDoc = Documents.Add(Template:="", NewTemplate:=False, DocumentType:=0)
    tempDoc.Windows(1).Visible = False
        
    ' 初期化
    errorText = ""
    stepSearch1 = 10
    stepSearch2 = 20
    stepSearch3 = 40
    step = 0
    
    ' 最適なトリミング単位を決定
    If stepSearch1 < Len(inputText) Then
        tempDoc.Content.Text = Mid(inputText, stepSearch1, Len(inputText) - stepSearch1)
        If tempDoc.GrammaticalErrors.count > 0 Then
            step = stepSearch1
        End If
    End If
    If stepSearch2 < Len(inputText) Then
        tempDoc.Content.Text = Mid(inputText, stepSearch2, Len(inputText) - stepSearch2)
        If tempDoc.GrammaticalErrors.count > 0 Then
            step = stepSearch2
        End If
    End If
    If stepSearch3 < Len(inputText) Then
        tempDoc.Content.Text = Mid(inputText, stepSearch3, Len(inputText) - stepSearch3)
        If tempDoc.GrammaticalErrors.count > 0 Then
            step = stepSearch3
        End If
    End If
    
    If step = 0 Then
        step = 20
    End If
    
    ' 文法エラーのある範囲を取得
    tempDoc.Content.Text = inputText
    If tempDoc.GrammaticalErrors.count > 0 Then
        Set errorRange = tempDoc.Content.GrammaticalErrors(1)
        ' 文法エラーの範囲の開始位置と終了位置を取得
        startPos = errorRange.Start
        endPos = errorRange.End
    Else
        GetGrammaticalErrorText = "利用不可"
        tempDoc.Close SaveChanges:=wdDoNotSaveChanges
        Exit Function
    End If
    
    ' 右側から削る処理
    rightPos = endPos
    Do While rightPos >= startPos
        testText = Mid(inputText, startPos + 1, rightPos - startPos)
        tempDoc.Content.Text = testText
        containsError = (tempDoc.GrammaticalErrors.count > 0)
        If Not containsError Then
            ' エラーがなくなったらstep分戻る
            rightPos = rightPos + step
            If rightPos > endPos Then rightPos = endPos
            
            ' 1文字ずつ削って正確な位置を特定
            Do While rightPos > startPos
                testText = Mid(inputText, startPos + 1, rightPos - startPos)
                tempDoc.Content.Text = testText
                containsError = (tempDoc.GrammaticalErrors.count > 0)
                If containsError Then
                    rightPos = rightPos - 1
                Else
                    Exit Do
                End If
            Loop
            rightPos = rightPos + 1 ' エラーが発生する直前の位置に戻す
            Exit Do
        End If
        rightPos = rightPos - step
        If rightPos < startPos Then rightPos = startPos
    Loop
    
    ' 左側から削る処理
    leftPos = startPos
    leftCounter = 0
    Do While leftPos <= rightPos
        testText = Mid(inputText, leftPos + 1, Len(inputText) - leftCounter)
        tempDoc.Content.Text = testText
        containsError = (tempDoc.GrammaticalErrors.count > 0)
        If Not containsError Then
            ' エラーがなくなったらstep分戻る
            leftPos = leftPos - step
            If leftPos < startPos Then leftPos = startPos
            
            ' 1文字ずつ削って正確な位置を特定
            Do While leftPos < rightPos
                testText = Mid(inputText, leftPos + 1, Len(inputText) - leftCounter)
                tempDoc.Content.Text = testText
                containsError = (tempDoc.GrammaticalErrors.count > 0)
                If containsError Then
                    leftPos = leftPos + 1
                Else
                    Exit Do
                End If
            Loop
            leftPos = leftPos - 1 ' エラーが発生する直前の位置に戻す
            Exit Do
        End If
        leftPos = leftPos + step
        If leftPos > rightPos Then leftPos = rightPos
        leftCounter = leftCounter + 1
    Loop

    If leftPos < 0 Then leftPos = 0

    errorText = Mid(inputText, leftPos + 1, rightPos - leftPos)

    ' 先頭の空白文字を削除
    Do While (Left(errorText, 1) = " " Or Left(errorText, 1) = "　" Or Left(errorText, 1) = vbTab)
        If errorText = "" Then Exit Do
        leftPos = leftPos + 1
        errorText = Mid(inputText, leftPos, rightPos - leftPos)
    Loop

    ' 文法エラーがない場合
    If errorText = "" Then
        errorText = "利用不可"
    End If
    
    tempDoc.Close SaveChanges:=wdDoNotSaveChanges
    Set tempDoc = Nothing
        
    ' エラー部分のテキストを返す
    GetGrammaticalErrorText = errorText
    
End Function

Function ConvertToUNC(doc As Document) As String
    Dim fso As Object
    Dim drv As Object
    Dim uncPath As String
    Dim localPath As String
    
    localPath = doc.FullName
    
    ' 先頭にコンピューター名が入っている場合は除去
    If Left(localPath, 2) = "\\" Then
        ' 3番目の\から後ろの文字列を切り出す
        Dim thirdBackslash As Long
        thirdBackslash = InStr(InStr(InStr(localPath, "\") + 1, localPath, "\") + 1, localPath, "\")
        localPath = Mid(localPath, thirdBackslash + 1)
        ' localPath中の$を:に変換
        localPath = Replace(localPath, "$", ":")
    End If
        
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' ドライブ文字を取得
    Dim driveLetter As String
    driveLetter = Left(localPath, 2)
    
    ' ネットワークドライブの場合
    If fso.GetDrive(driveLetter).DriveType = 3 Then ' 3 はネットワークドライブ
        Set drv = fso.GetDrive(driveLetter)
        uncPath = drv.ShareName & Mid(localPath, 3)
    Else
        ' ローカルドライブの場合、コンピューター名を取得してUNCパスを構築
        uncPath = "\\" & Environ$("COMPUTERNAME") & "\" & Replace(driveLetter, ":", "$") & Mid(localPath, 3)
    End If
    
    Set fso = Nothing
    Set drv = Nothing
    
    ConvertToUNC = uncPath
End Function

Function GetFirstCharacterPageNumber(rng As Range) As Long
    Dim firstCharRange As Range
    
    ' 範囲の最初の文字だけを含む新しい範囲を作成
    Set firstCharRange = rng.Duplicate
    firstCharRange.End = firstCharRange.Start
    
    ' 最初の文字を含むページ番号を取得して返す
    GetFirstCharacterPageNumber = firstCharRange.Information(wdActiveEndPageNumber)
End Function

Function RemoveSpecificCharacterOnTheLeftandRight(str As String, errText As String, charToRemove As String) As String
    Dim errPos As Long
    Dim leftBreakPos As Long
    Dim rightBreakPos As Long
    
On Error GoTo ErrorHandler
    
    errPos = InStr(str, errText)
          
    ' 右側の文字を削除（errPosからstr中にcharToRemoveがあるかを左から検索）
    rightBreakPos = InStr(errPos, str, charToRemove)
    If rightBreakPos > 0 Then
        str = Left(str, rightBreakPos - Len(charToRemove))
    End If
    
    ' 左側の文字を削除(errPosからstr中にcharToRemoveがあるかを右から検索）
    leftBreakPos = InStrRev(str, charToRemove, errPos)
    If leftBreakPos > 0 Then
        str = Right(str, Len(str) - leftBreakPos)
    End If
    
    RemoveSpecificCharacterOnTheLeftandRight = str

    Exit Function

ErrorHandler:

    ' エラーが発生した場合、元の文字列をそのまま返す
    RemoveSpecificCharacterOnTheLeftandRight = str
    
End Function