[VBA]テキスト中のプレースホルダーを一括置換する

まえおき

VBA上で文字列を組み立てるのはとても面倒くさい。

結合する文字列が多いと、以下のように、&祭りが開催される。
さらに、インデントを整えたりと、もともとの文章が長かったりして、一か所でもダブルクォーテーションをつけ忘れると地獄を見る。

というわけで、もっとスマートに置換処理を施していく。

    Dim joined_text as string
    joined_text = "param1~3は" & param1 & param2 & param3 & vbcrlf 
    joined_text = joned_text & "param4~6は" & param4 & param5 & param6 & vbcrlf

やりたいこと

プレースホルダーを持つ文字列を一括置換する

置換した箇所に対してハイライト色を設定する

ソースコード

■PlaceholderResolver モジュール

Option Explicit

' プレースホルダーの囲い文字
Private Const PLACEHOLDER_PREFIX As String = "<@" 
Private Const PLACEHOLDER_SUFFIX As String = "@>"

'
' text内のプレースホルダーを置換する
' text        : プレースホルダーを持つ文字列
' replace_dic : key - 置換前文字列, value - 置換後文字列
'
Public Function GetReplacedText( _
    text As String _
    , replace_dic As Dictionary _
) As String
    text = ResolvePlaceholder(text, replace_dic)
    text = Replace(text, PLACEHOLDER_PREFIX, "")
    text = Replace(text, PLACEHOLDER_SUFFIX, "")
    GetReplacedText = text
End Function



'
' text内のプレースホルダーを置換しdest_rangeに出力する
' 出力後、置換文字列に対してハイライト色を設定する
' text        : プレースホルダーを持つ文字列
' dest_range  : 置換後文字列の出力先セル
' replace_dic : key - 置換前文字列, value - 置換後文字列
'
Public Sub ReplaceAndHighlightCellValue( _
    text As String _
    , dest_range As Range _
    , replace_dic As Dictionary _
)

    ' テキストを置換する
    text = ResolvePlaceholder(text, replace_dic)
    
    ' 置換箇所を取得する
    Dim reg As RegExp
    Set reg = New RegExp
    reg.Global = True
    ' 「.+?」の場合「.」が改行文字にヒットしないため「\s\S」としている
    reg.Pattern = PLACEHOLDER_PREFIX & "[\s\S]+?" & PLACEHOLDER_SUFFIX
    Dim matches As MatchCollection
    Dim m As match
    Set matches = reg.Execute(text)
    For Each m In matches
        Debug.Print m.FirstIndex
        Debug.Print m.Length
    Next
    
    ' プレースホルダーの囲い文字を削除する
    text = Replace(text, PLACEHOLDER_PREFIX, "")
    text = Replace(text, PLACEHOLDER_SUFFIX, "")
    dest_range.Value = text
    
    Dim count As Long
    count = 0
    Dim enclosure_length As Long
    enclosure_length = (Len(PLACEHOLDER_PREFIX) + Len(PLACEHOLDER_SUFFIX))
    For Each m In matches
        dest_range.Characters( _
            m.FirstIndex - (count * enclosure_length) + 1 _
            , m.Length - enclosure_length).Font.Color = RGB(255, 0, 0)
        count = count + 1
    Next
End Function



'
' text内のパラメータ名(プレースホルダーの囲い文字を除く)のリストを取得する
' text: プレースホルダーを含む文字列
'
Public Function GetParamNamesFromText(text As String) As Collection

    Dim param_names As Collection
    Set param_names = New Collection
    
    Dim reg As RegExp
    Set reg = New RegExp
    reg.Global = True
    reg.Pattern = PLACEHOLDER_PREFIX & "([\s\S]+?)" & PLACEHOLDER_SUFFIX
    Dim matches As MatchCollection
    Dim m As match
    Set matches = reg.Execute(text)
    For Each m In matches
        param_names.Add (m.SubMatches(0))
    Next
    
    Set GetParamNamesFromText = param_names
End Function



'
' プレースホルダーを実文字列で置換する
' ハイライトを付ける関係上、囲い文字は残したまま返却する
' text         : プレースホルダーを含む文字列
' replace_dic  : key - 置換前文字列, value - 置換後文字列
'
Private Function ResolvePlaceholder(text As String, replace_dic As Dictionary) As String

    ' 置換対象文字列
    Dim param_name As Variant
    For Each param_name In replace_dic
        ' プレースホルダー
        Dim placeholder As String
        placeholder = "<@" & param_name & "@>"
        ' 置換後文字列
        Dim replace_value As String
        replace_value = replace_dic.Item(param_name)
        text = Replace(text, placeholder, "<@" & replace_value & "@>")
    Next
    ResolvePlaceholder = text
End Function

■呼び出しモジュール

Option Explicit

Public Sub test()
    
    ' 置換マップ
    Dim replace_table As Dictionary
    Set replace_table = New Dictionary
    Call replace_table.Add("HP", "1400")
    Call replace_table.Add("MP", "300")
    Call replace_table.Add("ATK", "230")
    Call replace_table.Add("DEF", "360")
    Call replace_table.Add("INTRO", "私は今日も元気です。" & vbCrLf & "よろしくお願いします。")
        
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    Dim src_range As Range
    Dim dest_range As Range
    Set src_range = sh.Range("B2")
    Set dest_range = sh.Range("C2")
    
    Debug.Print (PlaceholderResolver.GetReplacedText(src_range.Value, replace_table))
    Dim param_names As Collection
    Set param_names = PlaceholderResolver.GetParamNamesFromText(src_range.Value)
    Call PlaceholderResolver.ReplaceAndHighlightCellValue(src_range.Value, dest_range, replace_table)
End Sub

Function GetReplacedText(text As String, replace_dic As Dictionary) As String
文字列を置換し、返却する

Sub ReplaceAndHighlightCellValue(text As String, dest_range As Range, replace_dic As Dictionary) As String
文字列を置換し、指定セルに出力する（上記キャプチャを参照）

Function GetParamNamesFromText(text As String) As Collection
文字列中のパラメータ名を取得する（HP, MP, ATK…)

簡単解説

文字色変更処理

VBAのReplaceメソッドやWorksheetFunction.Replace関数を実行すると、セルの書式設定の情報が欠落してしまうため
以下の処理を進めると、パラメータ1の文字色の変更が保持できない。

パラメータ1を置換する
パラメータ1の変更後文字列の文字色を変更する
パラメータ2を置換する
パラメータ2の変更後文字列の文字色を変更する

そのため、Sub ReplaceAndHighlightCellValueでは全ての文字色変更箇所をreg.Excecute()で列挙しておき、次に文字色を一括で変更するということをしている。

えんすく！

まったりプログラミング