Excel形状与文本框搜索宏的问题排查及优化请求

问题背景 #

作为财务从业人员，制作的含形状的SOP流程文档无法用Excel默认Ctrl+F搜索形状内文本，使用AI生成的VBA宏存在两个问题：

1. 存在多个匹配结果时仅能找到1个，遗漏其余重复匹配项；
2. 找到结果后无法让屏幕居中显示该结果，不便查看。

问题1：修复多匹配项遗漏 #

问题根源 #

原代码遍历形状时未添加错误处理，若遇到无文本框的形状（如线条、图片）会触发运行时错误，直接终止搜索流程，导致后续匹配项被遗漏；同时仅限定搜索msoTextBox和msoShapeRectangle两种形状，可能错过其他含文本的形状类型。

修改方案 #

1. 在形状遍历过程中添加错误捕获，自动跳过无法访问文本的形状；
2. 扩大搜索范围，检查所有支持文本框的形状，而非仅限定两种类型。

问题2：实现屏幕居中显示结果 #

问题根源 #

原代码使用Application.Goto仅能定位到目标对象，但不会将其居中显示在屏幕视图中，无法快速聚焦到匹配结果。

修改方案 #

• 对于单元格：计算当前窗口可见区域的行/列数，将目标单元格调整到视图中心；
• 对于形状：获取形状的中心位置，调整窗口滚动位置使形状居中显示。

修改后的完整代码 #

模块代码（基础搜索功能） #

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
        MsgBox "请输入搜索关键词"
        Exit Sub
    End If
    
    ' 重置搜索结果集合
    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 "未在任何形状或单元格中找到指定文本"
    Else
        MsgBox "共找到 " & searchResults.Count & " 个匹配结果"
        ShowNextResult
    End If
End Sub

Sub SearchShapes(ws As Worksheet)
    Dim shp As Shape
    For Each shp In ws.Shapes
        On Error Resume Next ' 添加错误处理，跳过无文本的形状
        If shp.TextFrame2 Is Nothing Then
            On Error GoTo 0
            Continue For
        End If
        On Error GoTo 0
        
        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)
                    ' 保存原格式
                    With textRange.Characters(startPos, Len(searchText)).Font
                        originalFontSizes.Add .Size
                        originalFontNames.Add .Name
                        originalFontColors.Add .Fill.ForeColor.RGB
                        originalFontBold.Add .Bold
                    End With
                    startPos = startPos + Len(searchText)
                End If
            Loop While startPos > 0 And startPos <= Len(textRange.Text)
        End If
    Next shp
End Sub

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

Sub ShowNextResult()
    If searchResults Is Nothing Or searchResults.Count = 0 Then Exit Sub
    
    ' 移除上一个结果的高亮
    If currentIndex > 0 Then
        RestoreResultFormat searchResults(currentIndex), currentIndex
    End If
    
    ' 切换到下一个结果
    currentIndex = currentIndex + 1
    If currentIndex > searchResults.Count Then
        currentIndex = 1
    End If
    
    ' 高亮并定位当前结果
    HighlightAndCenterResult searchResults(currentIndex), currentIndex
    
    ' 设置10秒后移除高亮
    Application.OnTime Now + TimeValue("00:00:10"), "RemoveHighlight"
End Sub

Sub ShowPreviousResult()
    If searchResults Is Nothing Or searchResults.Count = 0 Then Exit Sub
    
    ' 移除上一个结果的高亮
    If currentIndex > 0 Then
        RestoreResultFormat searchResults(currentIndex), currentIndex
    End If
    
    ' 切换到上一个结果
    currentIndex = currentIndex - 1
    If currentIndex < 1 Then
        currentIndex = searchResults.Count
    End If
    
    ' 高亮并定位当前结果
    HighlightAndCenterResult searchResults(currentIndex), currentIndex
    
    ' 设置10秒后移除高亮
    Application.OnTime Now + TimeValue("00:00:10"), "RemoveHighlight"
End Sub

' 通用：恢复结果原格式
Sub RestoreResultFormat(result As Variant, index As Integer)
    On Error Resume Next
    If TypeName(result(0)) = "Range" Then
        With result(0).Characters(result(1), Len(searchText)).Font
            .Color = originalFontColors(index)
            .Bold = originalFontBold(index)
            .Underline = xlUnderlineStyleNone
            .Size = originalFontSizes(index)
            .Name = originalFontNames(index)
        End With
    Else
        With result(0).TextFrame2.TextRange.Characters(result(1), Len(searchText)).Font
            .Fill.ForeColor.RGB = originalFontColors(index)
            .Bold = originalFontBold(index)
            .UnderlineStyle = msoNoUnderline
            .Size = originalFontSizes(index)
            .Name = originalFontNames(index)
        End With
    End If
    On Error GoTo 0
End Sub

' 通用：高亮并居中显示结果
Sub HighlightAndCenterResult(result As Variant, index As Integer)
    Dim ws As Worksheet
    Set ws = result(2)
    ws.Activate
    
    If TypeName(result(0)) = "Range" Then
        ' 高亮单元格文本
        With result(0).Characters(result(1), Len(searchText)).Font
            .Color = RGB(255, 255, 0)
            .Bold = True
            .Underline = xlUnderlineStyleSingle
            .Size = 14
        End With
        ' 居中显示单元格
        CenterCellInWindow result(0)
    Else
        Dim shp As Shape
        Set shp = result(0)
        ' 高亮形状文本
        With shp.TextFrame2.TextRange.Characters(result(1), Len(searchText)).Font
            .Fill.ForeColor.RGB = RGB(255, 255, 0)
            .Bold = msoTrue
            .UnderlineStyle = msoUnderlineSingle
            .Size = 14
        End With
        ' 居中显示形状
        CenterShapeInWindow shp
    End If
End Sub

' 将单元格居中显示在窗口
Sub CenterCellInWindow(cell As Range)
    Dim visibleRows As Long, visibleCols As Long
    With ActiveWindow
        visibleRows = .VisibleRange.Rows.Count
        visibleCols = .VisibleRange.Columns.Count
        
        ' 计算滚动行：让目标单元格位于视图中间
        .ScrollRow = cell.Row - (visibleRows \ 2)
        ' 确保滚动行不小于1
        If .ScrollRow < 1 Then .ScrollRow = 1
        
        ' 计算滚动列：让目标单元格位于视图中间
        .ScrollColumn = cell.Column - (visibleCols \ 2)
        ' 确保滚动列不小于1
        If .ScrollColumn < 1 Then .ScrollColumn = 1
        
        ' 选中单元格
        cell.Select
    End With
End Sub

' 将形状居中显示在窗口
Sub CenterShapeInWindow(shp As Shape)
    With ActiveWindow
        ' 获取形状中心对应的单元格
        Dim centerCell As Range
        Set centerCell = .RangeFromPoint(shp.Top + shp.Height / 2, shp.Left + shp.Width / 2)
        
        ' 计算滚动位置，使形状中心与窗口中心对齐
        .ScrollRow = centerCell.Row - (.VisibleRange.Rows.Count \ 2)
        .ScrollColumn = centerCell.Column - (.VisibleRange.Columns.Count \ 2)
        
        ' 确保滚动位置不越界
        If .ScrollRow < 1 Then .ScrollRow = 1
        If .ScrollColumn < 1 Then .ScrollColumn = 1
        
        ' 选中形状
        shp.Select
    End With
End Sub

Sub RemoveHighlight()
    On Error Resume Next
    If searchResults Is Nothing Or searchResults.Count = 0 Or currentIndex = 0 Then Exit Sub
    RestoreResultFormat searchResults(currentIndex), currentIndex
    On Error GoTo 0
End Sub

Sub RemoveHighlights()
    On Error Resume Next
    If searchResults Is Nothing Then Exit Sub
    
    Dim i As Integer
    i = 1
    For Each result In searchResults
        RestoreResultFormat result, i
        i = i + 1
    Next result
    
    ' 释放资源
    Set searchResults = Nothing
    Set originalFontSizes = Nothing
    Set originalFontNames = Nothing
    Set originalFontColors = Nothing
    Set originalFontBold = Nothing
    currentIndex = 0
End Sub

ThisWorkbook代码 #

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    On Error Resume Next
    RemoveHighlights
    On Error GoTo 0
End Sub

frmSearch用户窗体代码 #

Private Sub btnSearch_Click()
    SearchTextInWorkbook
End Sub

Private Sub btnNext_Click()
    ShowNextResult
End Sub

Private Sub btnPrevious_Click()
    ShowPreviousResult
End Sub

内容的提问来源于stack exchange，提问作者Radostin Mohammad