如何在多工作簿多工作表中查找值并返回offset行数据

原代码核心问题 #

1. 工作簿对象被覆盖：连续执行Set wbY = Workbooks.Open(...)时，每次赋值都会覆盖之前的wbY对象，最终仅处理最后一个打开的工作簿，前面的文件完全没参与查找。
2. 查找范围未匹配实际数据起始行：原代码从A1开始搜索，但实际数据起始行是3或5行，表头会干扰查找结果。
3. Find方法参数缺失：未指定LookAt:=xlWhole，会匹配单元格内的部分文本（比如查找"ABC"会命中"ABCD"），导致漏找或错误匹配。
4. 复制逻辑冗余：逐个写27个Offset赋值，代码冗余且不易维护。
5. 无目录遍历功能：无法自动扫描目录及子文件夹中的Excel文件，只能手动指定路径。

修正后的完整代码 #

Sub CopyValuesFromAllWorkbooks()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim lastRowSource As Long
    Dim sourceValues As Variant
    Dim i As Long
    
    ' 打开源工作簿
    Set wbSource = Workbooks.Open("C:\Users\BRTY\OneDrive\Documents\values_to_find.xlsm")
    Set wsSource = wbSource.Sheets("Sheet1")
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' 将源数据存入数组，提升查找效率
    sourceValues = wsSource.Range("A1:A" & lastRowSource).Value
    
    ' 调用递归函数遍历目标目录及子文件夹
    TraverseFolder "Z:\ Team\Spreadsheets"
    
    ' 保存源工作簿并关闭
    wbSource.Save
    wbSource.Close
    
    MsgBox "数据查找完成！"
End Sub

' 递归遍历目录及子文件夹中的Excel文件
Sub TraverseFolder(folderPath As String)
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    Dim wbTarget As Workbook
    Dim wsTarget As Worksheet
    Dim lastRowTarget As Long
    Dim searchRange As Range
    Dim foundCell As Range
    Dim searchStartRow As Long
    Dim firstFoundAddress As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 遍历当前文件夹中的文件
    For Each file In folder.Files
        ' 只处理Excel文件
        If LCase(fso.GetExtensionName(file.Path)) Like "xls*" Then
            ' 跳过源工作簿本身
            If file.Path <> "C:\Users\BRTY\OneDrive\Documents\values_to_find.xlsm" Then
                Set wbTarget = Workbooks.Open(file.Path, ReadOnly:=True)
                ' 遍历目标工作簿的所有工作表
                For Each wsTarget In wbTarget.Sheets
                    ' 判断数据起始行（这里假设通过表头判断，或可根据实际情况调整）
                    ' 示例：如果A3或A5有数据，判断起始行
                    If wsTarget.Cells(3, "A").Value <> "" And wsTarget.Cells(3, "A").Value <> "表头" Then
                        searchStartRow = 3
                    ElseIf wsTarget.Cells(5, "A").Value <> "" And wsTarget.Cells(5, "A").Value <> "表头" Then
                        searchStartRow = 5
                    Else
                        searchStartRow = 1 ' 默认起始行，可根据实际调整
                    End If
                    
                    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
                    ' 仅当有数据时执行查找
                    If lastRowTarget >= searchStartRow Then
                        ' 搜索A列和B列的数据区域
                        Set searchRange = wsTarget.Range("A" & searchStartRow & ":B" & lastRowTarget)
                        
                        ' 遍历源数据数组
                        For i = 1 To UBound(sourceValues)
                            If sourceValues(i, 1) <> "" Then
                                ' 使用Find方法，指定精确匹配
                                Set foundCell = searchRange.Find(What:=sourceValues(i, 1), _
                                    LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                                
                                If Not foundCell Is Nothing Then
                                    firstFoundAddress = foundCell.Address
                                    ' 处理所有匹配项（避免重复查找同一单元格）
                                    Do
                                        ' 复制右侧最多27个单元格的值到源工作簿
                                        wsSource.Cells(i, 2).Resize(1, 27).Value = _
                                            foundCell.Offset(0, 1).Resize(1, 27).Value
                                        ' 继续查找下一个匹配项
                                        Set foundCell = searchRange.FindNext(foundCell)
                                    Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddress
                                End If
                            End If
                        Next i
                    End If
                Next wsTarget
                
                ' 关闭目标工作簿，不保存
                wbTarget.Close SaveChanges:=False
            End If
        End If
    Next file
    
    ' 递归遍历子文件夹
    For Each subFolder In folder.SubFolders
        TraverseFolder subFolder.Path
    Next subFolder
End Sub

关键优化点 #

• 递归遍历目录：通过Scripting.FileSystemObject实现自动扫描目标目录及所有子文件夹中的Excel文件，无需手动指定路径。
• 工作簿对象正确处理：每个文件单独打开、处理、关闭，避免对象覆盖问题。
• 适配数据起始行：通过判断A3/A5的内容确定数据起始行，跳过表头干扰。
• 精确查找：添加LookAt:=xlWhole参数，确保只匹配完全一致的单元格内容。
• 批量复制：用Resize(1,27)一次性复制27个单元格，替代冗余的逐个Offset赋值。
• 数组存储源数据：将源工作簿A列数据存入数组，提升遍历效率。
• 只读打开目标文件：避免修改目标工作簿，同时提升打开速度。

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