エクセルデータでワード文書中の文字列をハイライトするマクロ

概要

このマクロは、エクセルファイルのA列のデータに基づいてワード文書中の文字列をハイライトするシンプルなワードマクロです。

このマクロは、普段ワード文書をよく使う方に役立つと思います。

エクセルファイルには複数のシートを登録することができ、マクロ実行時にシートを選択できます。

半角全角の区別、小文字大文字の区別とハイライト色の選択も可能です。

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

詳細説明

マクロの準備

１．ワードマクロの実行方法～dotmファイルの作成～に記載したステップ①の１～６までを実施した後、ステップ①の７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。

コピペすると、以下の状態になります。

２．ワードマクロの実行方法 １．dotmファイルの作成に記載したステップ①の８から２２までを行ってください

（ステップ①の１１では、「Project.Module1.HighlightExcelDataInWord」を選択してから、追加ボタンを押してください（以下のイラストのようにしてください））

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

（ステップ①の２０での保存名は何でもいいです）

以上でマクロの準備が完了しました！

このマクロをどのワード文書からも呼び出せるようにしたい場合は、ワードマクロの実行方法 １ ～dotmファイルのの作成～に記載したステップ②も行ってください。

（このマクロは、ハイライトしたい文書を開いて、そこからマクロを呼び出すことが基本の使用方法になるため、ステップ②を行う方が便利です）

エクセルファイルの作成

以下のイラストのように、ハイライトしたい文字列をエクセルファイルのA列に登録します。

（A列以外の列をメモなどに使用してもかいません。マクロが使用するのはA列のみであることだけ覚えておいてください）

用途別に複数のシートにデータを登録することができます。

データの登録数に制限はありません。

以上でエクセルファイルの準備は完了です！

これで、マクロを使用するためのすべての準備が整いました。

マクロの使用方法

以下の手順で簡単にマクロを実行できます（念のためデータのバックアップ後に実行するようにしてください）

１．ハイライトしたいご自分のワードファイルを開いてください（上記の「マクロの準備」でステップ②まで実施した人）

　ステップ①のみを実施した人はハイライトマクロのdotmファイルを開き（上部にセキュリティ警告が出た場合は、「コンテンツの有効化」をクリックしてください）、そのdotmファイルに、ハイライトしたい文書の内容をコピペしてください。

２．マクロを実行します。

（アイコンは、各自が選んだアイコンになります）

３．ハイライトしたい文字列を登録したエクセルファイルを選択します

４．使用したいシートを選択します（番号を入力後にOKボタンを押します）

　エクセルファイルに含まれているシートが自動でピックアップされて一覧表示されます。

　使用したいシートの番号を入力してください。

５．ハイライト色を選択します（番号を入力後にOKボタンを押します）

　好きなハイライト色を数字で選んでください。

　６を選んだ場合は、既にハイライトされている色を解除することができます。

６．モードを選択します（番号を入力後にOKボタンを押します）

　半角全角の区別、小文字大文字の区別の必要性に応じて好きなモードを数字で選んでください。

７．内容を確認します（よければ「はい」を選択します）

　ハイライト条件が合っているかを確認してください。

　「はい」を押すと処理が始まります。

　処理状況は、ワード文書の左下に表示されます。

８．エクセルのデータを基にしてワード文書内の該当文字列がハイライトされます

　以下のイラストは、黄色のハイライト色を選んだ場合のものです。

ハイライト後に、必要に応じてワード文書を保存してください。

（マクロでは、自動保存は行われません）

マクロの使用方法は以上です。

コード

以下は、ハイライトマクロのコードです。

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

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

詳細説明に戻る場合はここをクリックしてください。

現在の公開バージョンはV01L04です。

Sub HighlightExcelDataInWord()
' V01L04
    Dim fd As FileDialog
    Dim excelFilePath As String
    Dim xlApp As Object, xlBook As Object
    Dim sheetNames() As String
    Dim i As Integer
    Dim sheetNameList As String
    Dim selectedSheetNumber As Variant
    Dim highlightColors As Variant
    Dim colorList As String
    Dim selectedColorNumber As Variant
    Dim highlightColor As Long
    Dim rng As Range
    Dim xlSheet As Object
    Dim cell As Object
    Dim mode As Variant
    Dim distinguishFullHalfWidth As Boolean
    Dim distinguishCase As Boolean
    Dim lastRow As Long
    Dim EmptyFlag As Boolean
    Dim RowCount As Long

    ' Show Excel file selection dialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.Title = "エクセルファイルを選択してください"
    fd.Filters.Clear
    fd.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
    If fd.Show = False Then Exit Sub
    excelFilePath = fd.SelectedItems(1)
    
    ' Check if the file is already open
    If isFileOpen(excelFilePath) Then
        MsgBox "選択したファイルは既に開かれています。閉じてから再度試してください。"
        Exit Sub
    End If
    
    ' Store all sheet names in an array
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open(excelFilePath)
    ReDim sheetNames(1 To xlBook.Sheets.Count)
    For i = 1 To xlBook.Sheets.Count
        sheetNames(i) = xlBook.Sheets(i).Name
    Next i
    
    ' Show all sheet names in an input box
    For i = 1 To UBound(sheetNames)
        sheetNameList = sheetNameList & i & ": " & sheetNames(i) & vbCrLf
    Next i
    
    Do
        selectedSheetNumber = InputBox("シートの番号(全角でも半角でも可)を入力してください" & vbCrLf & vbCrLf & vbCrLf & sheetNameList, "シートの選択")
        
        ' Check if the input box was cancelled or nothing was entered
        If selectedSheetNumber = "" Then
            If StrPtr(selectedSheetNumber) = 0 Then
                xlBook.Close SaveChanges:=False
                xlApp.Quit
                Exit Sub
            Else
                MsgBox "番号を入力してください。"
            End If
        Else
            ' Check if the input is a valid number
            If IsNumeric(selectedSheetNumber) Then
                If selectedSheetNumber < 1 Or selectedSheetNumber > UBound(sheetNames) Then
                    MsgBox "無効な番号が入力されました。"
                Else
                    Exit Do
                End If
            Else
                MsgBox "無効な番号が入力されました。"
            End If
        End If
    Loop

    ' Show input box to select highlight color
    highlightColors = Array("黄色", "グレー", "水色", "緑色", "青緑", "ハイライト解除")
    For i = 0 To UBound(highlightColors)
        colorList = colorList & i + 1 & ": " & highlightColors(i) & vbCrLf
    Next i
    
    Do
        selectedColorNumber = InputBox("ハイライト色の番号（全角でも半角でも可）を入力してください：" & vbCrLf & vbCrLf & vbCrLf & colorList, "ハイライト色の選択")
        
        ' Check if the input box was cancelled
        If StrPtr(selectedColorNumber) = 0 Then
            xlBook.Close SaveChanges:=False
            xlApp.Quit
            Exit Sub
        End If
        
        ' Map the selected color to the corresponding Word WdColor constant
        Select Case selectedColorNumber
            Case 1
                highlightColor = wdYellow
            Case 2
                highlightColor = wdGray25
            Case 3
                highlightColor = wdTurquoise
            Case 4
                highlightColor = wdBrightGreen
            Case 5
                highlightColor = wdTeal
            Case 6
                highlightColor = wdNoHighlight
            Case Else
                MsgBox "有効な色番号を入力してください"
                selectedColorNumber = ""
        End Select
    Loop Until selectedColorNumber <> ""

    Do
        ' Show input box to select mode
        mode = InputBox(Prompt:="モードの番号（全角でも半角でも可）を入力してください：" & vbCrLf & vbCrLf & vbCrLf & _
                        "　１: 半角全角の区別なし、小文字大文字の区別なし" & vbCrLf & vbCrLf & _
                        "　２: 半角全角の区別あり、小文字大文字の区別なし" & vbCrLf & vbCrLf & _
                        "　３: 半角全角の区別なし、小文字大文字の区別あり" & vbCrLf & vbCrLf & _
                        "　４: 半角全角の区別あり、小文字大文字の区別あり" & vbCrLf & vbCrLf, _
                        Title:="モードの選択")
    
        ' Exit if cancelled
        If mode = "" Then
            If StrPtr(mode) = 0 Then
                xlBook.Close SaveChanges:=False
                xlApp.Quit
                Exit Sub
            End If
        End If
        
        Select Case mode
            Case 1
                distinguishFullHalfWidth = False
                distinguishCase = False
                modeMessage = "検索モード：半角全角の区別なし、小文字大文字の区別なし"
                Exit Do
            Case 2
                distinguishFullHalfWidth = True
                distinguishCase = False
                modeMessage = "検索モード：半角全角の区別あり、小文字大文字の区別なし"
                Exit Do
            Case 3
                distinguishFullHalfWidth = False
                distinguishCase = True
                modeMessage = "検索モード: 半角全角の区別なし、小文字大文字の区別あり"
                Exit Do
            Case 4
                distinguishFullHalfWidth = True
                distinguishCase = True
                modeMessage = "検索モード：半角全角の区別あり、小文字大文字の区別あり"
                Exit Do
            Case Else
                MsgBox "有効なモードを入力してください"
        End Select
    Loop


    ' Display confirmation message to the user
    msgBoxResult = MsgBox("以下の条件で検索します。よろしいですか" & vbCr & vbCr & _
                "選択シート：" & sheetNames(selectedSheetNumber) & vbCr & "ハイライト色：" & highlightColors(selectedColorNumber - 1) & vbCr & modeMessage, vbYesNo + vbDefaultButton2, "確認")
    If msgBoxResult = vbNo Then
        xlBook.Close SaveChanges:=False
        xlApp.Quit
        Exit Sub ' If the user selects "No", the process will terminate
    End If
        
    ' Search A column values in Word and highlight
    Set rng = ActiveDocument.Content
    Set xlSheet = xlBook.Sheets(sheetNames(selectedSheetNumber))
    
    ' Get the last non-blank cell in column A
    lastRow = xlSheet.UsedRange.Row + xlSheet.UsedRange.Rows.Count - 1
    
    ' Check if column A is empty
    If lastRow = 1 And IsEmpty(xlSheet.Cells(1, 1).Value) Then
        MsgBox "A列にデータが存在しません"
        xlBook.Close SaveChanges:=False
        xlApp.Quit
        Exit Sub
    End If

    EmptyFlag = True
    RowCount = 0
    For Each cell In xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(lastRow, 1))
        RowCount = RowCount + 1
        Call UpdateStatusBar(RowCount, lastRow)
        ' Skip if the cell is empty
        If IsEmpty(cell.Value) Then GoTo NextCell
        EmptyFlag = False
        ' Search in the main document
        Set rng = ActiveDocument.Content ' Reset the range before each search
        With rng.Find
            .Text = cell.Value
            .MatchCase = distinguishCase ' Match case
            .MatchByte = distinguishFullHalfWidth ' Match full/half width
            .MatchFuzzy = False ' Turn off fuzzy matching
            Do While .Execute
                If .Found = True Then
                    rng.HighlightColorIndex = highlightColor
                    rng.Collapse wdCollapseEnd ' Move the range after the found text
                End If
            Loop
        End With
        ' Search in all text boxes
        For Each shp In ActiveDocument.Shapes
            If shp.Type = msoTextBox Then
                Set rng = shp.TextFrame.TextRange
                With rng.Find
                    .Text = cell.Value
                    .MatchCase = distinguishCase ' Match case
                    .MatchByte = distinguishFullHalfWidth ' Match full/half width
                    .MatchFuzzy = False ' Turn off fuzzy matching
                    Do While .Execute
                        If .Found = True Then
                            rng.HighlightColorIndex = highlightColor
                            rng.Collapse wdCollapseEnd ' Move the range after the found text
                        End If
                    Loop
                End With
            End If
        Next shp
NextCell:
    Next cell

    ' Close Excel and release all objects
    xlBook.Close SaveChanges:=False
    xlApp.Quit
    Set rng = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    Application.StatusBar = "処理が終了しました"
    
    If EmptyFlag = True Then
        MsgBox "A列にデータが存在しません"
        Exit Sub
    End If
End Sub

Function isFileOpen(filePath) As Boolean
    Dim ff As Long
    On Error Resume Next
    ff = FreeFile()
    Open filePath For Input Lock Read As #ff
    isFileOpen = IIf(Err.Number <> 0, True, False)
    Close #ff
End Function

Sub UpdateStatusBar(num As Long, denom As Long)
    If denom <> 0 Then
        Dim percent As Double
        percent = num / denom * 100
        Application.StatusBar = "処理中: " & Format(percent, "0.0") & "% 完了"
    Else
        Application.StatusBar = "分母が0です。パーセントを計算できません。"
    End If
End Sub

詳細説明に戻る場合はここをクリックしてください。

以上でハイライトマクロの紹介は終わりです。

最後まで読んでいただきましてありがとうございました！

他のマクロも是非見て行ってください。