多工作表VBA搜索工具开发求助：按输入值提取带格式数据

现有包含多个工作表的Excel工作簿，各表列范围为A至AO，行数不固定。需要开发VBA实现以下功能：

• 弹出InputBox接收单个/多个（逗号分隔）搜索值
• 遍历所有工作表查找匹配项
• 新建工作簿，将原表两行表头（所有表表头一致）复制到新表第1、2行
• 将所有匹配行的内容及格式从新表第3行开始依次粘贴

原代码运行时出现搜索值相关报错，求可用解决方案。原代码如下：

Sub SearchForValues()
    Dim ws As Worksheet
    Dim searchValue As String
    Dim searchRange As Range
    Dim foundCell As Range
    Dim outputRow As Long
    Dim outputCol As Long
    Dim i As Long
    Dim outputBook As Workbook
    Dim outputSheet As Worksheet
    Dim headerRange As Range
    
    ' Prompt user for the search value(s)
    searchValue = InputBox("Enter the value(s) to search for (separate multiple values with comma):")
    If searchValue = "" Then Exit Sub ' User cancelled or didn't enter a value
    
    ' Create a new workbook to output the results
    Set outputBook = Workbooks.Add
    Set outputSheet = outputBook.Sheets(1)
    outputSheet.Name = "Search Results"
    
    ' Write the headers to the output sheet
    Set headerRange = ThisWorkbook.Sheets("Sheet x").Range("A2:AO2")
    headerRange.Copy outputSheet.Range("A1")
    Set headerRange = ThisWorkbook.Sheets("Sheet x").Range("A1:AO1")
    headerRange.Copy outputSheet.Range("A2")
    
    ' Loop through each worksheet in the workbook
    For Each ws In ThisWorkbook.Worksheets
        ' Search for the values in columns A to AO of the worksheet
        Set searchRange = ws.Range("A:AO")
        For Each searchValue In Split(searchValue, ",")
            Set foundCell = searchRange.Find(searchValue, LookIn:=xlValues, LookAt:=xlWhole)
            
            ' If the value is found, output the row data to the output workbook
            If Not foundCell Is Nothing Then
                ' Write the sheet name and row number to the output sheet
                outputRow = outputSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' Move to the next free row in the output sheet
                outputSheet.Cells(outputRow, 1).Value = ws.Name
                outputSheet.Cells(outputRow, 2).Value = foundCell.Row
                
                ' Loop through each column and output the cell value and format
                outputCol = 1 ' Start outputting data in column 1
                For i = 1 To searchRange.Columns.Count
                    ws.Cells(foundCell.Row, i).Copy
                    outputSheet.Cells(outputRow, outputCol).PasteSpecial xlPasteFormats
                    outputSheet.Cells(outputRow, outputCol).PasteSpecial xlPasteValues
                    outputCol = outputCol + 1
                Next i
            End If
        Next searchValue
    Next ws
    
    ' Auto-fit the columns on the output sheet
    outputSheet.Columns.AutoFit
    
    ' Save and close the output workbook
    outputBook.SaveAs "Search Results.xlsx"
    outputBook.Close

    Application.VBE.MainWindow.Visible = False

End Sub

1. 变量名冲突：用searchValue同时存储用户输入字符串和遍历拆分后的值，导致遍历逻辑混乱，是核心报错原因。
2. 表头复制顺序错误：原代码将原表第二行表头复制到新表第一行，顺序不符合需求。
3. Find方法缺陷：仅查找第一个匹配项，遗漏后续结果；未重置查找起始位置，可能引发死循环。
4. 硬编码工作表名：ThisWorkbook.Sheets("Sheet x")为固定名称，原工作簿无此表时会报错。
5. 保存逻辑不完善：直接用固定文件名保存，若路径无权限或文件已存在会报错。
6. 粘贴效率低下：逐单元格粘贴值和格式，运行速度慢。

Sub SearchForValues()
    Dim ws As Worksheet
    Dim inputSearchValues As String
    Dim searchItems() As String
    Dim searchVal As Variant
    Dim searchRange As Range
    Dim foundCell As Range
    Dim firstFoundAddr As String
    Dim outputRow As Long
    Dim outputBook As Workbook
    Dim outputSheet As Worksheet
    Dim headerRange As Range
    Dim i As Long
    Dim isDuplicate As Boolean
    
    ' 获取用户输入的搜索值
    inputSearchValues = InputBox("输入要搜索的值（多个值用逗号分隔）:")
    If inputSearchValues = "" Then Exit Sub
    
    ' 拆分搜索值并去除前后空格
    searchItems = Split(Trim(inputSearchValues), ",")
    For i = LBound(searchItems) To UBound(searchItems)
        searchItems(i) = Trim(searchItems(i))
    Next i
    
    ' 创建结果工作簿
    Set outputBook = Workbooks.Add
    Set outputSheet = outputBook.Sheets(1)
    outputSheet.Name = "搜索结果"
    
    ' 复制表头（取第一个工作表的两行表头）
    If ThisWorkbook.Worksheets.Count > 0 Then
        Set headerRange = ThisWorkbook.Worksheets(1).Range("A1:AO2")
        headerRange.Copy outputSheet.Range("A1")
    End If
    outputRow = 3 ' 从第3行开始写入匹配数据
    
    ' 遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        ' 缩小搜索范围为已使用区域的A至AO列
        Set searchRange = Intersect(ws.UsedRange, ws.Range("A:AO"))
        If Not searchRange Is Nothing Then
            ' 遍历每个搜索值
            For Each searchVal In searchItems
                If searchVal <> "" Then
                    ' 查找第一个匹配项
                    Set foundCell = searchRange.Find(searchVal, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not foundCell Is Nothing Then
                        firstFoundAddr = foundCell.Address
                        Do
                            ' 检查当前行是否已添加到结果中，避免重复
                            isDuplicate = False
                            For i = 3 To outputRow - 1
                                If outputSheet.Cells(i, 1).Value = ws.Name And outputSheet.Cells(i, 2).Value = foundCell.Row Then
                                    isDuplicate = True
                                    Exit For
                                End If
                            Next i
                            
                            If Not isDuplicate Then
                                ' 写入工作表名和行号
                                outputSheet.Cells(outputRow, 1).Value = ws.Name
                                outputSheet.Cells(outputRow, 2).Value = foundCell.Row
                                ' 复制整行内容和格式到结果表
                                ws.Range(ws.Cells(foundCell.Row, 1), ws.Cells(foundCell.Row, 41)).Copy
                                outputSheet.Cells(outputRow, 3).PasteSpecial xlPasteAll
                                outputRow = outputRow + 1
                            End If
                            
                            ' 查找下一个匹配项
                            Set foundCell = searchRange.FindNext(foundCell)
                        Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddr
                    End If
                End If
            Next searchVal
        End If
    Next ws
    
    ' 自动调整列宽
    outputSheet.Columns.AutoFit
    
    ' 处理保存逻辑，避免覆盖已有文件
    Dim savePath As String
    savePath = Application.DefaultFilePath & "\搜索结果.xlsx"
    If Dir(savePath) <> "" Then
        savePath = Application.DefaultFilePath & "\搜索结果_" & Format(Now(), "YYYYMMDD_HHMMSS") & ".xlsx"
    End If
    outputBook.SaveAs savePath
    outputBook.Close SaveChanges:=False
    
    ' 清除剪贴板
    Application.CutCopyMode = False
End Sub

• 解决变量冲突：拆分变量职责，用inputSearchValues存原始输入、searchItems存拆分后的值、searchVal做循环变量，避免逻辑混乱。
• 修复表头复制：直接复制原表A1:AO2区域到新表A1，保证表头顺序正确。
• 完整查找匹配：用FindNext配合firstFoundAddr实现全范围查找，避免遗漏或死循环。
• 避免重复行：添加重复检查，同一行即使匹配多个搜索值也只添加一次。
• 优化搜索范围：缩小搜索范围为已使用区域，提升运行效率。
• 完善保存逻辑：自动生成带时间戳的文件名，避免覆盖已有文件。
• 提升粘贴效率：整行复制粘贴xlPasteAll，替代逐单元格操作，大幅提速。

内容的提问来源于stack exchange，提问作者Rob E