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!
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.