[VBA] ブック内の図形内のテキストを検索・置換するマクロ（Qiitaの記事の拡張）

Dec 11, 2020 · この記事は約4分で読めます · Excel VBA ·

Share on:

概要

この記事について

Qiitaで見たこちらの記事を参考に、
ブック内のすべての図形で検索できるように拡張したマクロです。
RelaxTools Addinを利用できない環境や、検索機能だけほしい場合に、
自分で使えたら便利かなと思い作成しました。

参考元：[Excel]図形内のテキストを検索・置換したい

説明のために作成したExcelファイルとソースコードはこちらでダウンロードできます。

コード

ほぼそのまんまです。
違いといえば例外処理のいくつかの流れの変更と、
未発見フラグと終了フラグの管理を自分的にわかりやすくしたところくらい。

モジュール内定数・変数

 1Option Explicit
 2'**************************
 3'*図形の文字列検索・置換
 4'*
 5'*referencing https://qiita.com/s-hchika/items/dda585fa0bdb829e9713
 6'**************************
 7
 8'定数
 9'ポップアップの名前
10Private Const TITLE_SEARCH_SHAPE_TEXT As String = "オートシェイプ検索"
11
12'変数
13'無し
14
15

searchShapeText

 1'******************************************************************************************
 2'*関数名    ：文字検索関数
 3'*機能      ：
 4'*引数      ：
 5'******************************************************************************************
 6Public Sub searchShapeText()
 7
 8    
 9    '定数
10    Const FUNC_NAME As String = "searchShapeText"
11    
12    '変数
13    Dim mySheets As Variant                     'ワークシートの集合体
14    Dim sheet As Variant
15    Dim searchWord As String                     '検索ワード
16    Dim flgTerminate As Boolean
17    Dim flgFound As Boolean
18    
19    On Error GoTo ErrorHandler
20    
21    'ブック内検索orシート検索
22    If MsgBox("ブック全体を検索場所としますか。", vbYesNo, TITLE_SEARCH_SHAPE_TEXT) = vbYes Then
23        '対象のワークシートを現在開いているブックの全てのシートとする
24        Set mySheets = ActiveWorkbook.Worksheets
25    Else
26        '対象のワークシートを現在開いているシートのみとする
27        mySheets = Array(ActiveSheet)
28    End If
29    
30    '検索ワード入力ポップアップを表示する
31    searchWord = Trim(InputBox("検索したいワードを入力して下さい。", TITLE_SEARCH_SHAPE_TEXT))
32
33    If searchWord = "" Then GoTo ExitHandler
34    
35    '検索
36    For Each sheet In mySheets
37        sheet.Activate
38        If Not searchReplaceShapeText(sheet.Shapes, searchWord, flgTerminate, flgFound) Then GoTo ExitHandler
39        '終了フラグTrueの場合
40        If flgTerminate Then GoTo ExitHandler
41    Next sheet
42    
43    'すべての検索範囲で未発見の場合
44    If Not flgFound Then MsgBox "「" & searchWord & "」が見つかりません。", vbExclamation, TITLE_SEARCH_SHAPE_TEXT
45    
46ExitHandler:
47
48    Exit Sub
49    
50ErrorHandler:
51
52    MsgBox "エラーが発生したため、マクロを終了します。" & _
53           vbLf & _
54           "関数名：" & FUNC_NAME & _
55           vbLf & _
56           "エラー番号：" & Err.Number & vbNewLine & _
57           Err.Description, vbCritical, TITLE_SEARCH_SHAPE_TEXT
58        
59    GoTo ExitHandler
60        
61End Sub
62

searchReplaceShapeText

  1'******************************************************************************************
  2'*関数名    ：searchReplaceShapeText
  3'*機能      ：図形内検索置換関数
  4'*引数      ：worksheetShapes Worksheetの図形コレクション
  5'*引数      ：searchWord      検索文字
  6'*引数      ：flgTerminate      探索終了フラグ
  7'*引数      ：flgFound      文字列発見フラグ
  8'*戻り値    ：True > 正常終了、False > 異常終了
  9'******************************************************************************************
 10Private Function searchReplaceShapeText(ByVal worksheetShapes As Object, ByVal searchWord As String, _
 11                                        ByRef flgTerminate As Boolean, ByRef flgFound As Boolean) As Boolean
 12
 13    
 14    '定数
 15    Const FUNC_NAME As String = "searchReplaceShapeText"
 16    
 17    '変数
 18    Dim targetShape  As Excel.Shape              'ワークシート内の図形
 19    Dim shapeText   As String                    '図形内の文字
 20    Dim discoveryWord As Long                    '検索ワード発見位置
 21    Dim replaceWord As String                    '置換後の文字
 22    Dim replacePopupMsg As String                '置換ポップアップメッセージ
 23    Dim searchWordCnt As Long: searchWordCnt = 1 '図形内検索ワード数
 24    
 25    On Error GoTo ErrorHandler
 26
 27
 28    'ワークシートに図形が存在する間ループ
 29    For Each targetShape In worksheetShapes
 30        Do
 31
 32            'クループ化された図形の時
 33            If (targetShape.Type = msoGroup) Then
 34    
 35                If Not (searchReplaceShapeText(targetShape.GroupItems, searchWord, flgTerminate, flgFound)) Then GoTo ExitHandler
 36                '終了フラグTrueの場合
 37                If flgTerminate Then GoTo TruePoint
 38    
 39                'コメントの時
 40            ElseIf (targetShape.Type = msoComment) Then
 41                Exit Do
 42            Else
 43                '指定したテキストフレームにテキストがあるかどうかを返す
 44                If (targetShape.TextFrame2.HasText) Then
 45    
 46                    '図形内のテキストを取得
 47                    shapeText = targetShape.TextFrame2.TextRange.Text
 48    
 49                    '図形内の文字列から検索
 50                    discoveryWord = InStr(shapeText, searchWord)
 51    
 52                    '検索ワードが見つかったとき、置換の処理を行う
 53                    If (discoveryWord > 0&) Then
 54                        
 55                        '文字列発見フラグTrue
 56                        flgFound = True
 57                        
 58                        'ウィンドウを図形の位置にスクロール
 59                        ActiveWindow.ScrollRow = targetShape.TopLeftCell.Row
 60                        ActiveWindow.ScrollColumn = targetShape.TopLeftCell.Column
 61    
 62                        Do While (discoveryWord > 0&)
 63                            
 64                            'テキスト範囲選択を解除するため、カレントセルを選択する
 65                            targetShape.TopLeftCell.Select
 66    
 67                            targetShape.TextFrame2.TextRange.Characters(discoveryWord, Len(searchWord)).Select
 68    
 69                            replacePopupMsg = "置換する場合、入力してください。" & vbNewLine & vbNewLine & "置換前 : " & searchWord & vbNewLine & "置換後"
 70    
 71                            ' 置換入力メッセージを出力する
 72                            replaceWord = InputBox(replacePopupMsg, "置換")
 73    
 74                            If Not replaceWord = "" Then
 75                            
 76                                '図形内の文字列を一箇所置換する
 77                                targetShape.TextFrame2.TextRange.Text = Replace(shapeText, searchWord, replaceWord, 1, searchWordCnt)
 78                                targetShape.TopLeftCell.Select
 79    
 80                            End If
 81    
 82                            '検索を継続するかどうか
 83                            If (MsgBox("continue?", vbQuestion Or vbOKCancel, TITLE_SEARCH_SHAPE_TEXT) <> vbOK) Then
 84                                flgTerminate = True
 85                                GoTo TruePoint
 86    
 87                                '同じ図形内で文字検索
 88                            Else
 89                                discoveryWord = InStr(discoveryWord + 1&, shapeText, searchWord)
 90                            End If
 91    
 92                        Loop
 93    
 94                    End If
 95                End If
 96            End If
 97        Loop While False
 98    Next
 99    
100
101TruePoint:
102
103    searchReplaceShapeText = True
104
105ExitHandler:
106    
107    
108    Exit Function
109    
110ErrorHandler:
111
112    MsgBox "エラーが発生したため、マクロを終了します。" & _
113           vbLf & _
114           "関数名：" & FUNC_NAME & _
115           vbLf & _
116           "エラー番号：" & Err.Number & vbNewLine & _
117           Err.Description, vbCritical, TITLE_SEARCH_SHAPE_TEXT
118        
119    GoTo ExitHandler
120        
121End Function

comments powered by Disqus

Translations:

"English" |