EXCEL VBA: A MACRO TO SEARCH AND REPLACE A TEXT OF SHAPES IN EXCEL BOOK

 1Option Explicit
 2'**************************
 3'*search and replace a text of shape
 4'*
 5'*referencing https://qiita.com/s-hchika/items/dda585fa0bdb829e9713
 6'**************************
 7
 8'Consts
 9'popup title
10Private Const TITLE_SEARCH_SHAPE_TEXT As String = "Auto Shape Search"
11
12'Vars
13'None
14
15

 1'******************************************************************************************
 2'*Function :the main processing of searching function
 3'******************************************************************************************
 4Public Sub searchMain()
 5
 6    
 7    'Consts
 8    Const FUNC_NAME As String = "searchMain"
 9    
10    'Vars
11    Dim mySheets As Variant                     'collection of worksheets
12    Dim sheet As Variant
13    Dim searchWord As String                     
14    Dim flgTerminate As Boolean
15    Dim flgFound As Boolean
16    
17    On Error GoTo ErrorHandler
18    
19    'search through the entire book or search through one sheet
20    If MsgBox("Do you want to search through the entire book?", vbYesNo, TITLE_SEARCH_SHAPE_TEXT) = vbYes Then
21        'the target is all sheets of current open book
22        Set mySheets = ActiveWorkbook.Worksheets
23    Else
24        'the target is only a active sheet
25        mySheets = Array(ActiveSheet)
26    End If
27    
28    'display a popup window to input the searched word
29    searchWord = Trim(InputBox("Input the word you want to search.", TITLE_SEARCH_SHAPE_TEXT))
30
31    If searchWord = "" Then GoTo ExitHandler
32    
33    'perform a search
34    For Each sheet In mySheets
35        sheet.Activate
36        If Not searchReplaceShapeText(sheet.Shapes, searchWord, flgTerminate, flgFound) Then GoTo ExitHandler
37        If flgTerminate Then GoTo ExitHandler
38    Next sheet
39    
40    'if not found, message is shown
41    If Not flgFound Then MsgBox """" & searchWord & """ is not found.", vbExclamation, TITLE_SEARCH_SHAPE_TEXT
42    
43ExitHandler:
44
45    Exit Sub
46    
47ErrorHandler:
48    MsgBox "An error has occurred and the macro will be terminated." & _
49           vbLf & _
50           "Func Name:" & FUNC_NAME & _
51           vbLf & _
52           "Error No." & Err.Number & vbNewLine & _
53           Err.Description, vbCritical, TITLE_SEARCH_SHAPE_TEXT
54        
55    GoTo ExitHandler
56        
57End Sub
58

  1'******************************************************************************************
  2'*Function :searching and replacing the text of the shape in target shape-collection
  3'*Arg      :shape-collection in the worksheet
  4'*Arg      :word for search
  5'*Arg      :termination flag
  6'*Arg      :flag of having found the word
  7'*Retrun    :True > normal termination; False > abnormal termination
  8'******************************************************************************************
  9Private Function searchReplaceShapeText(ByVal worksheetShapes As Object, ByVal searchWord As String, _
 10                                        ByRef flgTerminate As Boolean, ByRef flgFound As Boolean) As Boolean
 11
 12    
 13    'Consts
 14    Const FUNC_NAME As String = "searchReplaceShapeText"
 15    
 16    'Vars
 17    Dim targetShape  As Excel.Shape              'current target shape
 18    Dim shapeText   As String                    'text of the shape
 19    Dim discoveryWord As Long                    'the position in which the word is discovered
 20    Dim replaceWord As String                    'word after replacing
 21    Dim replacePopupMsg As String                'popup message for replacing
 22    Dim searchWordCnt As Long: searchWordCnt = 1 'word count in the shape
 23    
 24    On Error GoTo ErrorHandler
 25
 26
 27    For Each targetShape In worksheetShapes
 28        Do
 29
 30            If (targetShape.Type = msoGroup) Then
 31                'if target shape is grouped
 32
 33                'call itself recursively
 34                If Not (searchReplaceShapeText(targetShape.GroupItems, searchWord, flgTerminate, flgFound)) Then GoTo ExitHandler
 35                'exit if termination flagged
 36                If flgTerminate Then GoTo TruePoint
 37    
 38            ElseIf (targetShape.Type = msoComment) Then
 39                'continue if it's comment object
 40                Exit Do
 41            Else
 42                'check if it has text
 43                If (targetShape.TextFrame2.HasText) Then
 44    
 45                    'get the text
 46                    shapeText = targetShape.TextFrame2.TextRange.Text
 47    
 48                    'get the position of hit word
 49                    discoveryWord = InStr(shapeText, searchWord)
 50    
 51                    'process replacing block if discovered
 52                    If (discoveryWord > 0&) Then
 53                        
 54                        'found flagged
 55                        flgFound = True
 56                        
 57                        'scroll to the position of the shape
 58                        ActiveWindow.ScrollRow = targetShape.TopLeftCell.Row
 59                        ActiveWindow.ScrollColumn = targetShape.TopLeftCell.Column
 60    
 61                        Do While (discoveryWord > 0&)
 62                            
 63                            'select current cell to cancel the previous selection of text range
 64                            targetShape.TopLeftCell.Select
 65
 66                            'select target text
 67                            targetShape.TextFrame2.TextRange.Characters(discoveryWord, Len(searchWord)).Select
 68
 69                            replacePopupMsg = "Input any text if you want to replace it with." & vbNewLine & vbNewLine & "Before: " & searchWord & vbNewLine & "After: "
 70    
 71                            'show inquiry message 
 72                            replaceWord = InputBox(replacePopupMsg, "Replace")
 73    
 74                            If Not replaceWord = "" Then
 75                            
 76                                'replace a hit text with given text
 77                                targetShape.TextFrame2.TextRange.Text = Replace(shapeText, searchWord, replaceWord, 1, searchWordCnt)
 78                                targetShape.TopLeftCell.Select
 79    
 80                            End If
 81    
 82                            'inquire if continue
 83                            If (MsgBox("continue?", vbQuestion Or vbOKCancel, TITLE_SEARCH_SHAPE_TEXT) <> vbOK) Then
 84                                flgTerminate = True
 85                                GoTo TruePoint
 86    
 87                            Else
 88                                'search text in the same shape
 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 "An error has occurred and the macro will be terminated." & _
113           vbLf & _
114           "Func Name:" & FUNC_NAME & _
115           vbLf & _
116           "Error No." & Err.Number & vbNewLine & _
117           Err.Description, vbCritical, TITLE_SEARCH_SHAPE_TEXT
118        
119    GoTo ExitHandler
120        
121End Function