[VBA]テンプレート検索・置換機能の実装

2025年8月3日2025年8月3日 eh657883

まえおき

社内の人事関連の仕事を進める上で、テンプレートをもとに文書を作成してから、Slackにて通知を行うという作業を行っている。テンプレートの文書はカテゴリごとにエクセルのシートに分けているのだが、なかなか探すのが手間である。そんなわけで、検索画面を追加して、シートを切り替えずとも必要なテンプレートを取得できるようなマクロを用意した。また、社員の名前など同じ情報がテンプレート中に何回か出てくることがあり、それを手作業で入れていくのは、前後の文字も削らないように気を付ける必要があるため、集中力を要する。それも嫌なので改善した。

マクロの機能

テンプレートの検索機能
テンプレートの置換機能

画面イメージ

テンプレート定義シート

置き換わる部分は <@パラメータ名@>で囲んでいる。

テンプレート検索画面

検索キーワード入力後、カテゴリ1,2,3,テンプレートのいずれかに合致する行を、検索結果に出力する
テンプレート置換画面

検索画面にて、転記リンクをクリックすることで、置換対象のパラメータをリストの左側に列挙する。右側に実際の値を埋め込むことで、置換文字列を削ることなく完成したテンプレートが出来上がる。

ソースコード

Option Explicit

' -------------------------------------------------------------
'  ユーザー設定定数 (テンプレート検索)
' -------------------------------------------------------------
Public Const SHEET_NAME_SEARCH = "テンプレート検索"
Public Const SHEET_NAME_REPLACE = "テンプレート置換"

' FAQテーブルの開始座標および列数
Public Const FAQ_TABLE_BEGIN_ROW As Long = 3
Public Const FAQ_TABLE_BEGIN_COLUMN As Long = 2
Public Const FAQ_TABLE_COLUMN_NUM As Long = 4
Public Const FAQ_SEARCHED_COUNT_MAX As Long = 20

' FAQ検索キーワード
Public Const FAQ_KEYWORD_ROW As Long = 4
Public Const FAQ_KEYWORD_COLUMN As Long = 3

' FAQ件数出力先
Public Const FAQ_RESULT_COUNT_ROW As Long = 7
Public Const FAQ_RESULT_COUNT_COLUMN As Long = 3

' FAQ結果出力先
Public Const FAQ_RESULT_TABLE_BEGIN_ROW As Long = 11
Public Const FAQ_RESULT_TABLE_BEGIN_COLUMN As Long = 3
Public Const FAQ_RESULT_TABLE_CULUMN_NUM As Long = FAQ_TABLE_COLUMN_NUM

' -------------------------------------------------------------
'  ユーザー設定定数 (テンプレート置換)
' -------------------------------------------------------------
Public Const TEMPLATE_PARAMETER_BEGIN_POS = "B4"
Public Const TEMPLATE_REPLACED_BEFORE = "B16"
Public Const TEMPLATE_REPLACED_AFTER = "C16"






' FAQの検索結果 (末尾はシート名)
Dim faqSearchedData(1 To FAQ_SEARCHED_COUNT_MAX, 1 To FAQ_TABLE_COLUMN_NUM + 1) As String
Dim faqSearchedCount As Long

Public Sub SearchFAQEntry(keyword As String)
    
    faqSearchedCount = 1
    Erase faqSearchedData
    
    ' テンプレート検索
    Call SearchFAQ(keyword)

    ' 件数出力
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(SHEET_NAME_SEARCH)
    sh.Cells(FAQ_RESULT_COUNT_ROW, FAQ_RESULT_COUNT_COLUMN) = faqSearchedCount - 1

    ' 結果出力
    Dim r As Range
    Set r = sh.Cells(FAQ_RESULT_TABLE_BEGIN_ROW, FAQ_RESULT_TABLE_BEGIN_COLUMN).Resize( _
        UBound(faqSearchedData, 1) _
        , UBound(faqSearchedData, 2) _
    )
    r.Value = faqSearchedData

End Sub

' キーワードに合致するFAQを検索する
' keyword: キーワード
' return : 結果FAQ -> faqSearchedData
Private Sub SearchFAQ(keyword As String)
    
    Dim shFAQ As Worksheet
    For Each shFAQ In ThisWorkbook.Worksheets
        If (shFAQ.Name <> SHEET_NAME_SEARCH _
            And shFAQ.Name <> SHEET_NAME_REPLACE) Then
            Call SearchFAQPerSheet(shFAQ, keyword)
        End If
    Next
End Sub

' 1シート単位で検索をする
Private Sub SearchFAQPerSheet(shFAQ As Worksheet, keyword As String)

    ' 1シート当たりのFAQの件数を取得する
    Dim lastRow As Long
    lastRow = shFAQ.Cells(Rows.Count, 3).End(xlUp).row
    If (lastRow < FAQ_TABLE_BEGIN_ROW) Then Exit Sub End If ' FAQのセル範囲を取得する Dim faqRange As Range Set faqRange = shFAQ.Cells(FAQ_TABLE_BEGIN_ROW, FAQ_TABLE_BEGIN_COLUMN) _ .Resize( _ lastRow - FAQ_TABLE_BEGIN_ROW + 1, _ (FAQ_TABLE_COLUMN_NUM) _ ) ' 二次元配列に変換 Dim faqArray As Variant faqArray = faqRange.Value ' キーワードの部分一致するFAQを結果配列に格納する Dim y As Long Dim x As Long For y = 1 To UBound(faqArray, 1) Dim findFlag As Boolean findFlag = False For x = 1 To UBound(faqArray, 2) If (InStr(faqArray(y, x), keyword) > 0) Then
                findFlag = True
                Exit For
            End If
        Next
        If (findFlag) Then
            For x = 1 To UBound(faqArray, 2)
               faqSearchedData(faqSearchedCount, x) = faqArray(y, x)
            Next
            faqSearchedData(faqSearchedCount, UBound(faqArray, 2) + 1) = shFAQ.Name
            faqSearchedCount = faqSearchedCount + 1
        End If
        
        ' 検索上限の場合、打ち切り
        If (faqSearchedCount > FAQ_SEARCHED_COUNT_MAX) Then
            Exit Sub
        End If
    Next
End Sub


' Sheet テンプレート検索
Option Explicit

' イベント
' 検索キーワードの入力
Private Sub Worksheet_Change(ByVal Target As Range)
    ' キーワード以外の入力であれば無視をする
    If Not (Target.row = FAQ_KEYWORD_ROW _
        And Target.column = FAQ_KEYWORD_COLUMN) Then
        Exit Sub
    End If

    Call SearchFAQEntry(Target.Value)
End Sub

' イベント
' 【転記】ハイパーリンクのクリック
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim template As String
    template = Target.Range.Offset(0, -2).Resize(1, 1).Value
    Debug.Print (template)
    
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(SHEET_NAME_REPLACE)
    
    Dim beforeRange As Range
    Set beforeRange = sh.Range(TEMPLATE_REPLACED_BEFORE)
    beforeRange.Value = template
    beforeRange.Font.Color = RGB(0, 0, 0)
    Call extractParams(beforeRange)
End Sub

' テンプレート内に含まれるパラメータを抽出する
Public Sub extractParams(templateRange As Range)

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(SHEET_NAME_REPLACE)
    
    Dim r As Range
    Set r = sh.Range(TEMPLATE_PARAMETER_BEGIN_POS)
    
    Dim reg As RegExp
    Set reg = New RegExp
    reg.Pattern = "<@.+?@>"
    reg.Global = True
    reg.MultiLine = True
    
    Dim match As Variant
    Set match = reg.Execute(templateRange.Value)
    
    Dim i As Long
    For i = 0 To match.Count - 1
        Dim paramName As String
        paramName = match(i).Value
        r.Offset(i, 0).Value = paramName
        r.Offset(i, 1).Value = ""
        templateRange.Characters(match(i).FirstIndex + 1, match(i).Length).Font.Color = RGB(255, 0, 0)
    Next
End Sub


' シート テンプレート置換
Option Explicit

' 入力変更イベント
Private Sub Worksheet_Change(ByVal Target As Range)
    
    ' パラメータ以外の入力であれば無視をする
    If Not (4 <= Target.row _
        And Target.row <= 13 _
        And Target.column = 3) Then
        Exit Sub
    End If
    
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(SHEET_NAME_REPLACE)
        
    ' 置換前テンプレート
    Dim beforeTemplateRange As Range
    Set beforeTemplateRange = sh.Range(TEMPLATE_REPLACED_BEFORE)
    
    ' 置換後テンプレート
    Dim afterTemplateRange As Range
    Set afterTemplateRange = sh.Range(TEMPLATE_REPLACED_AFTER)
    
    ' パラメータ
    Dim paramsBeginRange As Range
    Set paramsBeginRange = sh.Range(TEMPLATE_PARAMETER_BEGIN_POS)
    
    Dim reg As RegExp
    Set reg = New RegExp
    reg.MultiLine = True
    reg.Global = True
    
    Dim template As String
    template = beforeTemplateRange.Value
    Dim paramRange As Range
    Set paramRange = paramsBeginRange
    
    ' パラメータを置換する
    Do While (paramRange.Value <> "")
        Dim src As String
        Dim dest As String
        src = paramRange.Offset(0, 0).Value
        dest = paramRange.Offset(0, 1).Value
        If (dest <> "") Then
            reg.Pattern = src
            template = reg.Replace(template, dest)
        End If
        Set paramRange = paramRange.Offset(1, 0)
    Loop
    afterTemplateRange.Value = template
    afterTemplateRange.Font.Color = RGB(0, 0, 0)
    
    ' 置換後のパラメータの文字色を変更する
    Set paramRange = paramsBeginRange
    Do While (paramRange.Value <> "")
        dest = paramRange.Offset(0, 1).Value
        If (dest <> "") Then
            reg.Pattern = dest
            
            Dim match As Variant
            Set match = reg.Execute(afterTemplateRange.Value)
            Dim i As Long
            For i = 0 To match.Count - 1
                afterTemplateRange.Characters(match(i).FirstIndex + 1, match(i).Length).Font.Color = RGB(255, 0, 0)
            Next
        End If
        Set paramRange = paramRange.Offset(1, 0)
    Loop
End Sub