ExcelVBAで指定キーワードの色付け

#文章の目視確認を効率化
特定のキーワード毎に本文に登場した分だけ文字色を変えて見たいニーズがあり作成。
最初はキーワードが最初に登場した部分だけ文字色を変えていたのを全部変わるように改善。
UserFormは適当に作成して選択したファイルを編集して上書き保存。
色は6色ループとこれまた適当なのでお好きにカスタマイズ可能。

```UserForm.bas
Private Sub UserForm_Initialize()

    パスラベル.Caption = ""
    
    シートコンボボックス.Clear
    シートコンボボックス.Enabled = False
    
    項目コンボボックス.Clear
    項目コンボボックス.Enabled = False
    
    キーワードテキストボックス.Value = ""
    キーワードテキストボックス.Enabled = False
    
    実行ボタン.Enabled = False

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    If CloseMode = 0 Then
    
        MsgBox "[×]ボタンでは閉じらません"
        
        Cancel = True
        
    End If
    
End Sub

Private Sub ファイル選択ボタン_Click()

    Dim FilePath As String
        
    FilePath = ThisWorkbook.Path & "\"
        
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = FilePath
        .Filters.Clear
        .Filters.Add "Excelブック", "*.xlsx"
        .Show

        If .SelectedItems.Count = 0 Then
    
            パスラベル.Caption = ""
        
            実行ボタン.Enabled = False
            
            シートコンボボックス.Clear
            
            シートコンボボックス.Enabled = False
            
            項目コンボボックス.Enabled = False
            
            キーワードテキストボックス.Enabled = False
            
            Exit Sub
    
        End If

        FilePath = .SelectedItems(1)
    
        パスラベル.Caption = FilePath
            
        シートコンボボックス.Enabled = True
                
        Call GetSheet

    End With

End Sub

Private Sub シートコンボボックス_Change()

    項目コンボボックス.Clear
    
    If シートコンボボックス.Value <> "" Then
        項目コンボボックス.Enabled = True
        Call GetCol
    End If
    
End Sub

Private Sub 項目コンボボックス_Change()

    If 項目コンボボックス.Value <> "" Then
    
        キーワードテキストボックス.Enabled = True
        実行ボタン.Enabled = True
        
    End If

End Sub

Sub GetSheet()
    
    Dim i As Long
    Dim FileName As String
    Dim book As Workbook
    Dim MaxSheet As Long
    
    FileName = パスラベル.Caption
    
    If FileName <> "False" Then
                       
        Set book = Workbooks.Open(FileName)
    
    End If
        
    book.Application.Visible = False
    
    ' 開いたファイルをアクティブにする
    book.Activate
    
    MaxSheet = book.Worksheets.Count
    
    For i = 1 To MaxSheet
        シートコンボボックス.AddItem book.Worksheets(i).Name
    Next i
    
    book.Close

End Sub

Sub GetCol()

    Dim j As Long
    Dim FileName As String
    Dim book As Workbook
    Dim sheet As Worksheet
    Dim SheetNum As Long
    Dim MaxCol As Long
        
    FileName = パスラベル.Caption
    
    If FileName <> "False" Then
                       
        Set book = Workbooks.Open(FileName)
    
    End If
        
    book.Application.Visible = False
    
    ' 開いたファイルをアクティブにする
    book.Activate
        
    SheetNum = シートコンボボックス.ListIndex + 1
        
    Set sheet = book.Worksheets(SheetNum)
    
    MaxCol = sheet.Cells(1, Columns.Count).End(xlToLeft).Column
    
    For j = 1 To MaxCol
        項目コンボボックス.AddItem sheet.Cells(1, j).Value
    Next j
    
    book.Close

End Sub

Private Sub 実行ボタン_Click()
    
    If 色指定チェックボックス.Value = True Then
        
        Me.Hide
        
        UserForm3.Show vbModeless
    
    Else
    
        Me.Hide
    
        UserForm2.Show vbModeless
    
        Call test
    
        Unload UserForm2
    
        Me.Show
        
    End If
    
End Sub

Private Sub 終了ボタン_Click()

    Unload UserForm1
    
    Application.ScreenUpdating = True
    Application.Visible = True
    
    Application.Quit
    
    ThisWorkbook.Close SaveChanges:=False
    
End Sub

```

```Coloring.bas
Sub sample()
    
    Dim i As Long
    Dim j As Long
    Dim ColNum As Long
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim Keyword As String
    Dim Target As Variant
    Dim Tcnt As Long
    Dim Tlen As Long
    Dim Search As Range
    Dim Pos As Long
    Dim FileName As String
    Dim book As Workbook
    
    FileName = UserForm1.パスラベル.Caption
    
    If FileName <> "False" Then
                       
        Set book = Workbooks.Open(FileName)
    
    End If
        
    book.Application.Visible = False
    
    ' 開いたファイルをアクティブにする
    book.Activate
    
    Sheets(UserForm1.シートコンボボックス.ListIndex + 1).Select

    ColNum = UserForm1.項目コンボボックス.ListIndex + 1
    MaxRow = Cells(Rows.Count, ColNum).End(xlUp).Row
    MaxCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    Keyword = UserForm1.キーワードテキストボックス.Value
    
    Target = Split(Keyword, vbCrLf)
    
    Tcnt = UBound(Target)
    
    For i = 0 To Tcnt
        Target(i) = Trim(Target(i))
        Tlen = Len(Target(i))
        Cells(1, MaxCol + i + 1).Value = Target(i)
        Select Case i Mod 6
            Case 0
                Cells(1, MaxCol + i + 1).Font.ColorIndex = 3
            Case 1
                Cells(1, MaxCol + i + 1).Font.ColorIndex = 5
            Case 2
                Cells(1, MaxCol + i + 1).Font.ColorIndex = 7
            Case 3
                Cells(1, MaxCol + i + 1).Font.ColorIndex = 21
            Case 4
                Cells(1, MaxCol + i + 1).Font.ColorIndex = 28
            Case 5
                Cells(1, MaxCol + i + 1).Font.ColorIndex = 46
        End Select
        Cells(1, MaxCol + i + 1).Font.Bold = True
        For j = 2 To MaxRow
            Set Search = Cells(j, ColNum)
            Pos = InStr(Search, Target(i))
            If Pos <> 0 Then
                Cells(j, MaxCol + i + 1).Value = Target(i)
            End If
            Do While Pos > 0
                Select Case i Mod 6
                    Case 0
                        Search.Characters(Pos, Tlen).Font.ColorIndex = 3
                    Case 1
                        Search.Characters(Pos, Tlen).Font.ColorIndex = 5
                    Case 2
                        Search.Characters(Pos, Tlen).Font.ColorIndex = 7
                    Case 3
                        Search.Characters(Pos, Tlen).Font.ColorIndex = 21
                    Case 4
                        Search.Characters(Pos, Tlen).Font.ColorIndex = 28
                    Case 5
                        Search.Characters(Pos, Tlen).Font.ColorIndex = 46
                End Select
                Search.Characters(Pos, Tlen).Font.Bold = True
                Search.Characters(Pos, Tlen).Font.Italic = True
                Pos = InStr(Pos + 1, Search, Target(i))
            Loop
        Next j
    Next i
    
    book.Save
    book.Close
        
End Sub

```