VBA多目录Excel数据合并问题求助：行号错误与循环异常

问题1：客户端工作表最后一行行号计算错误 #

原因 #

所有未指定工作表对象的Range、Cells调用，都会默认引用当前活动工作表，而非你正在遍历的目标工作表：

• cellValue = Range("A33").Value实际取的是活动表的A33，不是wsClient的A33，可能导致空值判断逻辑出错
• overallLR = Cells(...)未绑定wsOverall，会用错工作表的行数据，导致主文档空白行位置计算错误

修复 #

所有单元格操作必须明确指定所属工作表：

• 将cellValue = Range("A33").Value改为cellValue = wsClient.Range("A33").Value
• 将主文档空白行计算改为overallLR = wsOverall.Cells(wsOverall.Rows.Count, 1).End(xlUp).Offset(1).Row
• 保留clientLR的绑定逻辑（原代码此处是正确的）

问题2：Do While循环重复打开同一文档 #

原因 #

For Each file In folder.Files已经是完整的文件遍历循环，内部嵌套的Do While file.Name <> ""没有终止条件（file.Name永远不为空），导致同一文件被无限重复打开处理。

修复 #

直接移除多余的Do While file.Name <> ""循环及其对应的Loop语句，仅保留外层的For Each file循环即可。

完整修复代码 #

Sub sourceFile2()
    Call loopThroughFiles("Z:\Filepath\")
End Sub

Sub loopThroughFiles(ByVal path As String)
    Dim fso As Object
    Set fso = CreateObject("scripting.FileSystemObject")
    Dim folder As Object
    Set folder = fso.GetFolder(path)
    Dim file As Object

    Dim wsOverall As Worksheet
    Dim wbOverall As Workbook
    Dim overallLR As Long
    Dim overallFilepath As String
    Dim overallFile As String

    Dim wbClient As Workbook
    Dim clientLR As Long
    Dim wsClient As Worksheet
    Dim cellValue As String

    ' 抑制提示并关闭屏幕刷新
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    ' 主文档目录路径
    overallFilepath = "Z:\Filepath\"
    overallFile = Dir(overallFilepath)

    ' 遍历主文档目录（若目录仅一个主文档，建议直接指定文件名打开）
    Do While overallFile <> ""
        Set wbOverall = Workbooks.Open(overallFilepath & overallFile)
        Set wsOverall = wbOverall.Sheets("Overall")
        ' 正确获取主文档第一个空白行
        overallLR = wsOverall.Cells(wsOverall.Rows.Count, 1).End(xlUp).Offset(1).Row
        overallFile = Dir()
    Loop

    ' 遍历客户端目录所有文件
    For Each file In folder.Files
        Set wbClient = Application.Workbooks.Open(path & file.Name)
        ' 遍历当前工作簿所有工作表
        For Each wsClient In wbClient.Worksheets
            ' 检查当前工作表A33是否有内容
            cellValue = wsClient.Range("A33").Value
            If cellValue <> "" Then
                ' 获取当前工作表A列最后一行
                clientLR = wsClient.Cells(wsClient.Rows.Count, "A").End(xlUp).Row
                ' 复制数据到主文档
                wsClient.Range("A33:U" & clientLR).Copy
                wsOverall.Range("A" & overallLR).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                ' 更新主文档空白行位置
                overallLR = wsOverall.Cells(wsOverall.Rows.Count, 1).End(xlUp).Offset(1).Row
            End If
        Next wsClient
        ' 关闭客户端工作簿
        wbClient.Close
    Next file

    ' 恢复提示和屏幕刷新
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

额外优化建议 #

1. 主文档处理优化：如果主文档目录只有一个目标文件，直接用Workbooks.Open("Z:\Filepath\你的主文档文件名.xlsx")打开，避免Dir循环误处理其他文件
2. 错误处理：添加On Error Resume Next或On Error GoTo语句，防止单个文件/工作表出错导致程序中断
3. 高效数据传递：替换剪贴板复制，直接用单元格赋值更高效：

   ' 替代Copy/Paste的赋值写法
   Dim targetRowCount As Long
   targetRowCount = clientLR - 33 + 1
   wsOverall.Range("A" & overallLR & ":U" & overallLR + targetRowCount - 1).Value = wsClient.Range("A33:U" & clientLR).Value
   wsOverall.Range("A" & overallLR & ":U" & overallLR + targetRowCount - 1).NumberFormat = wsClient.Range("A33:U" & clientLR).NumberFormat
   

内容的提问来源于stack exchange，提问作者Space Noodles