ワードマクロの旧バージョン置き場

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