VBAで文章中の指定単語に色付けするやつ、を作ろうとして苦労した点色々

普段VBA全然使わない人が雰囲気で書こうとして苦労したとこ集です。
（普段使わないので変な記述あったらツッコミください。）

作りたいもの（完成図）

今回作りたかったものはこんなものです。

• Excelに書かれた文章の中で指定の単語部分を色付けして強調する
• ついでに強調した単語を抽出する
• ついでのついでに抽出するときに文字を置き換える機能も付ける

まず文章を入力して

別シートに色付けしたい単語（１列目）とどう置き換えるか（２列目）を記入して

マクロ実行すると

こうなってほしい、みたいなものです。
文字の置き換え抽出の用途としては、図の「流した、流れる」のように活用系のものをまとめたい、とか漢字・記号・カタカナのようにカテゴリ分けしてみるとかそういうのを想定しています。
（置き換えは必要があってついでで作った機能なのであまり汎用的ではないかも。）

VBA作成

処理内容と該当のコード、苦労したTips等をバラバラと書いていきます。
完成版は一番最後に張っておきます。

ざっくり設計

やりたい処理を分解します。

３シートを準備して

• 文章を入力する[文章シート]
• 強調したい単語を記載する[単語シート]
• 置き換え単語が抽出される[抽出シート]

矢印部分のような処理を作ります。

• ① 一行ずつ文章を読み込んで単語一覧と突き合わせ
• ② 一致した部分の色を変える
• ③ 単語の置き換え
• ④ 重複を除外して対応する行に追加

①文章の読み込みと単語突合

一行ずつ処理をする処理はRangeで処理する場所を指定してFor文で一行ずつループします。

With wsMain 'シートの指定
    For Each sentence In .range(.range("A2"), .range("A" & Rows.Count).End(xlUp))
        ' 処理書く
    Next sentence
End With

A2セルから入力のある最終行までを指定します。
最終行部分の指定は（Excelを使っている方だとピンとくるかも）一番下から上に向かってCtrl+↑をしている動きになります。
これで入力範囲をしていして一行ずつ回します。

強調する単語を抽出する処理も同様に、指定の場所を囲ったrangeを用意します。
将来的にシートが増えても良いように関数化してWorksheetを受け取るようにした例です。

領域抽出の関数

'強調する単語のリストを取得する
Function getPickupWords(ByRef ws As Worksheet) As range
    Dim rg As range
        
    With ws
        Set rg = .range(.range("A1"), .range("A" & Rows.Count).End(xlUp))
    End With
    
    Set getPickupWords = rg
End Function

getPickupWordsで強調（色付け）すべき単語が取得できるので、この単語一覧もFor文で回していき文章の内の単語を色付けしていくイメージです。
まとめるとこんな感じ。

'メインの処理関数
Function setColor2Sentence(ByRef wsMain As Worksheet, ByRef wsWordList As Worksheet, ByRef wsWork As Worksheet, colorIndex As Integer)
    wsWork.Cells.Clear
    
    With wsMain
        For Each sentence In .range(.range("A2"), .range("A" & Rows.Count).End(xlUp))
            For Each word In getPickupWords(wsWordList)
                ' 文章と単語を受け取って色付けする処理を実装していく
                ' Call setColor2Word(sentence, word, wsWordList, wsWork, colorIndex)
            Next word
        Next sentence
    End With
End Function

A列全部だということでFor Each sentence In .range("A:A")のように指定すると、Excelの一番下（104万行）までループが回ってしまうので処理が超重くなるので注意。

②一致した部分の色変え

上記①の色付けを実行するsetColor2Word関数の中身をまとめます。

文章(sentence)中に単語(word)があるかを調べるのInStr()というのがあります。
InStr(1, sentence, word)
第一引数はどこから検索を始めるかで、この関数は単語を見つけるとその場所を返してくれます。
ただし文章中で単語を一つ見つけると終了してしまうので、すべての単語を見つけきるまでループするようにします。

Dim idx As Integer

Do
    idx = InStr(idx + 1, sentence, word)
    If idx <> 0 Then
        '文章中の単語に色を付ける
        sentence.Characters(Start:=idx, Length:=Len(word)).Font.colorIndex = 3
    End If
Loop Until idx = 0

こんな感じでできました。
このときwordが空文字""だった場合、全てにマッチしてしまうので注意が必要です。
word = ""のときに処理をスキップするように処理を追加します。
If word <> "" Thenのようにしてしまっても良いのですが、ループをスキップしたい場面も出てきそうなので他の言語で言うところのnext/continue/breakなどに相当する方法を調べてみました。
・・・あれ、ない？
ので、GoToで指定の場所まで飛ばすことでcontinueやbreakの動きをさせている例が多いのでそうしてみます。

Function setColor2Word(sentence, word, ByRef wsWordList As Worksheet, ByRef wsWork As Worksheet, colorIndex As Integer)
    Dim idx As Integer

    If word = "" Then GoTo Continue
    Do
        idx = InStr(idx + 1, sentence, word)
        If idx <> 0 Then
            '文章中の単語に色を付ける
            sentence.Characters(Start:=idx, Length:=Len(word)).Font.colorIndex = 3
        End If
    Loop Until idx = 0
Continue:
End Function

このあたりのループから離脱に関する処理はVB6やVBAではcontinueに相当する処理がなかったりVB2005ではcontinue Forみたいな構文ができたりと、お使いの環境で変わりそうです。

単に色を付ける部分のみが必要でしたらここまででOKです。

③ 単語の置き換え

次に単語の置き換えです。
置き換えというか、VLookUp関数の動きというほうがイメージがわかりやすいかもしれません。
特定の行で検索して、一致した場合隣のセルを見るということをします。

指定のRangeの中に指定の文字があるかを見るためにMatchを使います。
ExcelでVLookUpの代わりにMatch/Indexを使うみたいな話もあったりしますがそれはまた別の話。

MatchなどのExcelからすでに提供されている関数はこんな感じで使えるようです。
WorksheetFunction.Match(word, range, 0)
これで実行すると単語が存在する場合は良いのですが、範囲内に一致する単語がなかった場合、エラーが発生して処理が止まってしまいます。
そのためエラーハンドリングするか事前に単語存在を保証する必要があります。
例えばCountIfで単語が一つ以上存在することを確認、ということをしてみます。

If WorksheetFunction.CountIf(range, word) Then
    wordIdx = WorksheetFunction.Match(word, range, 0)
Else

これで指定の単語の行数が取得できるので、その行の指定列を取得することでVLookUp的な処理ができます。
こんな感じ。

単語の変換関数

'単語に置き換え語が設定されている場合そちらを取得する
Function getWordCategory(ByRef ws As Worksheet, ByVal word As String) As String
    Dim wordIdx As Double
    Dim category As String
    
    With ws
        Set rg = getPickupWords(ws)
        If WorksheetFunction.CountIf(rg, word) Then
            wordIdx = WorksheetFunction.Match(word, rg, 0)
            category = .Cells(wordIdx, 2).Value
        Else
            category = ""
        End If
    End With
    
    getWordCategory = IIf(category <> "", category, word)
End Function

④ 重複を除外して対応する行に追加

その文章で強調した単語を抽出します。
強調したい単語が文章中に複数出てきた場合はすべて色付けしますが、単語として抽出したい場合は重複を除去したい（という用途だった）ので実装します。

重複を除去というのがこれまたVBAだと面倒です。ざっと調べた感じだと

• どこかのシートの列に列挙してフィルター機能で重複除去
• Dictionary型を有効にして活用
• Collection型を有効にして活用

みたいな例があるようです。
今回はもうシートを配列に見立てて作っていきます。

やることは今までの応用で指定の領域に単語あるかを見て、なければ右のセルに付け足すということをしています。
単語抽出用のworkシートとしてwsWorkがあるとして、こんなイメージです。

With wsWork
    Set wordCategoryList = .range(.Cells(sentence.Row, 1), .Cells(sentence.Row, .Cells(sentence.Row, 256).End(xlToLeft).Column))
    'リスト（行）に存在しない場合末尾に追加
    If 0 = WorksheetFunction.CountIf(wordCategoryList, addWord) Then
        .Cells(sentence.Row, .Cells(sentence.Row, 256).End(xlToLeft).Column + 1).Value = addWord
    End If
End With

全体

全部の合わせた完成版です。
必要な用途があって作ったもの（汎用的な機能ではない）なので、そのまま使うというよりは何か困ったときにどこかがヒントになればと。

[文書シート]・・・文章入力用のシート名
[赤文字、青文字シート]・・・色付けする単語を入れるシート名
[work_赤文字、work_青文字シート]・・・見つけた単語を抽出するシート名

全部

'強調する単語のリストを取得する
Function getPickupWords(ByRef ws As Worksheet) As range
   Dim rg As range
       
   With ws
       Set rg = .range(.range("A1"), .range("A" & Rows.Count).End(xlUp))
   End With
   
   Set getPickupWords = rg
End Function

'単語に置き換え語が設定されている場合そちらを取得する
Function getWordCategory(ByRef ws As Worksheet, ByVal word As String) As String
   Dim wordIdx As Double
   Dim category As String
   
   With ws
       Set rg = getPickupWords(ws)
       If WorksheetFunction.CountIf(rg, word) Then
           wordIdx = WorksheetFunction.Match(word, rg, 0)
           category = .Cells(wordIdx, 2).Value
       Else
           category = ""
       End If
   End With
   
   getWordCategory = IIf(category <> "", category, word)
End Function

'文章中の指定単語に色を付ける
'また色をつけた単語を別シートに記載する
Function setColor2Word(sentence, word, ByRef wsWordList As Worksheet, ByRef wsWork As Worksheet, colorIndex As Integer)
   Dim addWord
   Dim idx As Integer
   Dim wordCategoryList As range
   
   If word = "" Then GoTo Continue
   
   Do
       idx = InStr(idx + 1, sentence, word)
               
       If idx <> 0 Then
           '文章中の単語に色を付ける
           sentence.Characters(Start:=idx, Length:=Len(word)).Font.colorIndex = colorIndex
           'ワードの変換
           addWord = getWordCategory(wsWordList, word)
           
           With wsWork
               Set wordCategoryList = .range(.Cells(sentence.Row, 1), .Cells(sentence.Row, .Cells(sentence.Row, 256).End(xlToLeft).Column))
               'リスト（行）に存在しない場合末尾に追加
               If 0 = WorksheetFunction.CountIf(wordCategoryList, addWord) Then
                   .Cells(sentence.Row, .Cells(sentence.Row, 256).End(xlToLeft).Column + 1).Value = addWord
               End If
           End With
       End If
   Loop Until idx = 0
Continue:
End Function

'メインの処理関数
Function setColor2Sentence(ByRef wsMain As Worksheet, ByRef wsWordList As Worksheet, ByRef wsWork As Worksheet, colorIndex As Integer)
   wsWork.Cells.Clear
   
   With wsMain
       For Each sentence In .range(.range("A2"), .range("A" & Rows.Count).End(xlUp))
           For Each word In getPickupWords(wsWordList)
               Call setColor2Word(sentence, word, wsWordList, wsWork, colorIndex)
           Next word
       Next sentence
   End With
End Function


Sub 単語の色付け()
   Dim wsMain As Worksheet
   Dim wsWordListRed As Worksheet, wsWordListBlue As Worksheet
   Dim wsWorkRed As Worksheet, wsWorkBlue As Worksheet
   
   Set wsMain = Worksheets("文章")
   Set wsWordListRed = Worksheets("赤文字")
   Set wsWordListBlue = Worksheets("青文字")
   Set wsWorkRed = Worksheets("work_赤文字")
   Set wsWorkBlue = Worksheets("work_青文字")
   
   ' 文字色のリセット
   wsMain.Columns("A:A").Font.colorIndex = xlAutomatic
   ' 赤文字
   Call setColor2Sentence(wsMain, wsWordListRed, wsWorkRed, 3)
   ' 青文字
   Call setColor2Sentence(wsMain, wsWordListBlue, wsWorkBlue, 5)
   
End Sub

ポチッと押すといい感じ。