excelvbaexcel-formula

Creating a Search Function Macro in Excel for Shapes and Text Boxes


Firstly, apologies if what I ask is not very logical or makes sense. I am in no way a coder/developer, etc.

I work in Finance and I am trying to create an SOP process with shapes that shows steps to follow, processes, etc.

I have all my SOP sorted our but after finishing it, I noticed that the basic Control+F search does not work :D

I used AI to create a VBA macro and I am constantly facing issues. Mainly the following:

A summary generated by the AI for the code:

Features of the Enhanced Search Function

User Form for Search Interface: A user form (frmSearch) with a text box for entering search keywords. Three buttons on the user form: "Search", "Next", and "Previous". Search Functionality:

Scans all shapes (text boxes and rectangles) and cells in each worksheet. Searches for the specified keyword within the text of shapes and cells. Stores the search results in a collection, including the position, worksheet, and original formatting (font size, font name, font color, and bold attribute). Navigation Functionality:

Allows navigation through the search results using "Next" and "Previous" buttons. Highlights the current search result in yellow and bolds the text. Sets a timer to revert the text formatting to its original state after 10 seconds. Highlighting and Reverting Formatting:

Highlights the current search result in yellow and bolds the text. Reverts the text formatting to its original state after 10 seconds. Cleanup Functionality:

Removes all highlights and formatting when navigating away from the sheet. Ensures that all highlights and formatting are removed when the workbook sheet is deactivated. Error Handling:

Includes error handling to avoid runtime errors during the search and navigation process. Button to Open User Form:

A button on the worksheet to open the user form for searching. Summary of the Code

User Form Code:

Module Code:

ThisWorkbook Code:

Code Module 1 - This is the base search function:

Dim searchResults As Collection
Dim currentIndex As Integer
Dim searchText As String
Dim originalFontSizes As Collection
Dim originalFontNames As Collection
Dim originalFontColors As Collection
Dim originalFontBold As Collection

Sub SearchTextInWorkbook()
    searchText = frmSearch.txtSearch.Text
    
    If searchText = "" Then Exit Sub
    
    Set searchResults = New Collection
    Set originalFontSizes = New Collection
    Set originalFontNames = New Collection
    Set originalFontColors = New Collection
    Set originalFontBold = New Collection
    currentIndex = 0
    
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        SearchShapes ws
        SearchCells ws
    Next ws
    
    If searchResults.Count = 0 Then
        MsgBox "Text not found in any shape or cell."
    Else
        MsgBox searchResults.Count & " result(s) found."
        ShowNextResult
    End If
End Sub

Sub SearchShapes(ws As Worksheet)
    Dim shp As Shape
    For Each shp In ws.Shapes
        If shp.Type = msoTextBox Or shp.Type = msoShapeRectangle Then
            If shp.TextFrame2.HasText Then
                Dim textRange As TextRange2
                Set textRange = shp.TextFrame2.textRange
                
                Dim startPos As Long
                startPos = 1
                
                Do
                    startPos = InStr(startPos, textRange.Text, searchText, vbTextCompare)
                    If startPos > 0 Then
                        searchResults.Add Array(shp, startPos, ws)
                        originalFontSizes.Add textRange.Characters(startPos, Len(searchText)).Font.Size
                        originalFontNames.Add textRange.Characters(startPos, Len(searchText)).Font.Name
                        originalFontColors.Add textRange.Characters(startPos, Len(searchText)).Font.Fill.ForeColor.RGB
                        originalFontBold.Add textRange.Characters(startPos, Len(searchText)).Font.Bold
                        startPos = startPos + Len(searchText)
                    End If
                Loop While startPos > 0
            End If
        End If
    Next shp
End Sub

Sub SearchCells(ws As Worksheet)
    Dim cell As Range
    For Each cell In ws.UsedRange
        Dim startPos As Long
        startPos = 1
        
        Do
            startPos = InStr(startPos, cell.Value, searchText, vbTextCompare)
            If startPos > 0 Then
                searchResults.Add Array(cell, startPos, ws)
                originalFontSizes.Add cell.Characters(startPos, Len(searchText)).Font.Size
                originalFontNames.Add cell.Characters(startPos, Len(searchText)).Font.Name
                originalFontColors.Add cell.Characters(startPos, Len(searchText)).Font.Color
                originalFontBold.Add cell.Characters(startPos, Len(searchText)).Font.Bold
                startPos = startPos + Len(searchText)
            End If
        Loop While startPos > 0
    Next cell
End Sub

Sub ShowNextResult()
    If searchResults Is Nothing Or searchResults.Count = 0 Then Exit Sub
    
    ' Remove highlight from previous result
    If currentIndex > 0 Then
        Dim prevResult As Variant
        prevResult = searchResults(currentIndex)
        If TypeName(prevResult(0)) = "Range" Then
            With prevResult(0).Characters(prevResult(1), Len(searchText)).Font
                .Color = originalFontColors(currentIndex)
                .Bold = originalFontBold(currentIndex)
                .Underline = xlUnderlineStyleNone
                .Size = originalFontSizes(currentIndex)
                .Name = originalFontNames(currentIndex)
            End With
        Else
            With prevResult(0).TextFrame2.textRange.Characters(prevResult(1), Len(searchText)).Font
                .Fill.ForeColor.RGB = originalFontColors(currentIndex)
                .Bold = originalFontBold(currentIndex)
                .UnderlineStyle = msoNoUnderline
                .Size = originalFontSizes(currentIndex)
                .Name = originalFontNames(currentIndex)
            End With
        End If
    End If
    
    ' Move to the next result
    currentIndex = currentIndex + 1
    If currentIndex > searchResults.Count Then
        currentIndex = 1
    End If
    
    ' Highlight the current result
    Dim currentResult As Variant
    currentResult = searchResults(currentIndex)
    If TypeName(currentResult(0)) = "Range" Then
        With currentResult(0).Characters(currentResult(1), Len(searchText)).Font
            .Color = RGB(255, 255, 0)
            .Bold = True
            .Underline = xlUnderlineStyleSingle
            .Size = 14
        End With
        currentResult(2).Activate
        currentResult(0).Select
        Application.Goto currentResult(0)
    Else
        With currentResult(0).TextFrame2.textRange.Characters(currentResult(1), Len(searchText)).Font
            .Fill.ForeColor.RGB = RGB(255, 255, 0)
            .Bold = msoTrue
            .UnderlineStyle = msoUnderlineSingle
            .Size = 14
        End With
        currentResult(2).Activate
        currentResult(0).Select
        Application.Goto currentResult(0).TopLeftCell
    End If
    
    ' Set a timer to remove the highlight after 10 seconds
    Application.OnTime Now + TimeValue("00:00:10"), "RemoveHighlight"
End Sub

Sub ShowPreviousResult()
    If searchResults Is Nothing Or searchResults.Count = 0 Then Exit Sub
    
    ' Remove highlight from previous result
    If currentIndex > 0 Then
        Dim prevResult As Variant
        prevResult = searchResults(currentIndex)
        If TypeName(prevResult(0)) = "Range" Then
            With prevResult(0).Characters(prevResult(1), Len(searchText)).Font
                .Color = originalFontColors(currentIndex)
                .Bold = originalFontBold(currentIndex)
                .Underline = xlUnderlineStyleNone
                .Size = originalFontSizes(currentIndex)
                .Name = originalFontNames(currentIndex)
            End With
        Else
            With prevResult(0).TextFrame2.textRange.Characters(prevResult(1), Len(searchText)).Font
                .Fill.ForeColor.RGB = originalFontColors(currentIndex)
                .Bold = originalFontBold(currentIndex)
                .UnderlineStyle = msoNoUnderline
                .Size = originalFontSizes(currentIndex)
                .Name = originalFontNames(currentIndex)
            End With
        End If
    End If
    
    ' Move to the previous result
    currentIndex = currentIndex - 1
    If currentIndex < 1 Then
        currentIndex = searchResults.Count
    End If
    
    ' Highlight the current result
    Dim currentResult As Variant
    currentResult = searchResults(currentIndex)
    If TypeName(currentResult(0)) = "Range" Then
        With currentResult(0).Characters(currentResult(1), Len(searchText)).Font
            .Color = RGB(255, 255, 0)
            .Bold = True
            .Underline = xlUnderlineStyleSingle
            .Size = 14
        End With
        currentResult(2).Activate
        currentResult(0).Select
        Application.Goto currentResult(0)
    Else
        With currentResult(0).TextFrame2.textRange.Characters(currentResult(1), Len(searchText)).Font
            .Fill.ForeColor.RGB = RGB(255, 255, 0)
            .Bold = msoTrue
            .UnderlineStyle = msoUnderlineSingle
            .Size = 14
        End With
        currentResult(2).Activate
        currentResult(0).Select
        Application.Goto currentResult(0).TopLeftCell
    End If
    
    ' Set a timer to remove the highlight after 10 seconds
    Application.OnTime Now + TimeValue("00:00:10"), "RemoveHighlight"
End Sub

Sub RemoveHighlight()
    On Error Resume Next ' Add error handling to avoid runtime errors
    
    If searchResults Is Nothing Or searchResults.Count = 0 Then Exit Sub
    
    Dim currentResult As Variant
    currentResult = searchResults(currentIndex)
    If TypeName(currentResult(0)) = "Range" Then
        With currentResult(0).Characters(currentResult(1), Len(searchText)).Font
            .Color = originalFontColors(currentIndex)
            .Bold = originalFontBold(currentIndex)
            .Underline = xlUnderlineStyleNone
            .Size = originalFontSizes(currentIndex)
            .Name = originalFontNames(currentIndex)
        End With
    Else
        With currentResult(0).TextFrame2.textRange.Characters(currentResult(1), Len(searchText)).Font
            .Fill.ForeColor.RGB = originalFontColors(currentIndex)
            .Bold = originalFontBold(currentIndex)
            .UnderlineStyle = msoNoUnderline
            .Size = originalFontSizes(currentIndex)
            .Name = originalFontNames(currentIndex)
        End With
    End If
End Sub

Sub RemoveHighlights()
    On Error Resume Next ' Add error handling to avoid runtime errors
    
    If searchResults Is Nothing Then Exit Sub
    
    Dim result As Variant
    Dim i As Integer
    i = 1
    For Each result In searchResults
        If TypeName(result(0)) = "Range" Then
            With result(0).Characters(result(1), Len(searchText)).Font
                .Color = originalFontColors(i)
                .Bold = originalFontBold(i)
                .Underline = xlUnderlineStyleNone
                .Size = originalFontSizes(i)
                .Name = originalFontNames(i)
            End With
        Else
            With result(0).TextFrame2.textRange.Characters(result(1), Len(searchText)).Font
                .Fill.ForeColor.RGB = originalFontColors(i)
                .Bold = originalFontBold(i)
                .UnderlineStyle = msoNoUnderline
                .Size = originalFontSizes(i)
                .Name = originalFontNames(i)
            End With
        End If
        i = i + 1
    Next result
    
    Set searchResults = Nothing
    Set originalFontSizes = Nothing
    Set originalFontNames = Nothing
    Set originalFontColors = Nothing
    Set originalFontBold = Nothing
    currentIndex = 0
End Sub

Code Workbook:

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    On Error Resume Next ' Add error handling to avoid runtime errors
    RemoveHighlights
End Sub

Code FormSearch (these are the buttons):

Private Sub btnSearch_Click()
    SearchTextInWorkbook
End Sub

Private Sub btnNext_Click()
    ShowNextResult
End Sub

Private Sub btnPrevious_Click()
    ShowPreviousResult
End Sub

This is quite a lot, I know, however, if anyone has had a similar problem or any advice on what to change, I would really appreciate it.

Thanks everyone!


Solution

  • Please forget AI for this and make it more simple - at least in case you need something functional and not something very fancy. Maybe this suits your needs:

    You can obtain a basic ctrl+f for shapes by using the built in Input Box functionality to enter the searched text, so no need for UserForms. After that you can make the code iterate through all the shapes on the current sheet using a For-Each-Loop and check if the shape text matches. To check for matches, we use the wildcard "*"-sign and add it to the search-text and use the LIKE-operator within an If-statement. So if the shapes text is like the searched text, then the codes does focus the shape, using Application.GoTo. Since Application.GoTo expects a range and not a shape as input, we need to obtain a cell under or next to the shape we want to focus. For this you can use the .TopLeftCell.Row and .TopLeftCell.Column property of the shape-object, so the code makes the screen "jump" to the shape and does highlight the shape in yellow by changing its color-properties. To restore the actual color afterwards, the .Fill.ForeColor.RGB of the shape is stored in a variable (lngActualColor) and applied afterwards.

    The code looks like this:

    Sub Search_in_Shapes()
    
    Dim strSearchText As String
    Dim objShape As Object
    Dim lngActualColor As Long
    
        strSearchText = "*" & UCase(InputBox("Text to search in Shapes:")) & "*"    
        If strSearchText = "**" Then Exit Sub 'if user presses 'cancel' or enters nothing
    
    Again:
    
        For Each objShape In ActiveSheet.Shapes
            
            With objShape
            
                If UCase(.TextFrame.Characters.Text) Like strSearchText Then
                    
                    Application.Goto Cells(.TopLeftCell.Row, .TopLeftCell.Column), Scroll:=True
                    
                    lngActualColor = .Fill.ForeColor.RGB
                    .Fill.ForeColor.RGB = vbYellow                
                    Application.ScreenUpdating = True  'mandatory for refreshing the shape-color (at least on my machine)
                    
                    If MsgBox("Found. Next?", vbQuestion + vbYesNo) = vbNo Then 'abort search
                    
                        .Fill.ForeColor.RGB = lngActualColor
                        Exit Sub
                        
                    End If
                    
                    .Fill.ForeColor.RGB = lngActualColor
                    
                End If
            
            End With
            
            DoEvents
        
        Next
        
        If MsgBox("No (more) matches. Again?", vbInformation + vbYesNo) = vbYes Then GoTo Again 'start iterating again
    
    End Sub
    

    Put that in a Module and you can use the routine by pressing alt+F8 on the sheet.

    The code does:

    The code does not:

    Finally: I'd recommend you really start learning some VBA, maybe by performing some simple worksheet manipulation. Its fun and you can get a ton out of it when working in Finance.