Excel多工作簿数据合并VBA运行异常问题求助

• 环境：Windows笔记本通过SharePoint打开Excel 365网页版，使用「在桌面打开」功能运行VBA；150个按客户命名的工作簿，每个工作簿内的工作表以员工命名，需将30名员工的数据汇总至月度工作簿。
• 故障：
  • Excel 365笔记本：程序可正常循环打开、关闭客户工作簿，但月度工作簿无任何数据追加。
  • Excel 2019台式机：首次运行能正常复制数据，后续运行完全失效。

针对Excel 365的核心修复 #

1. 修正SharePoint同步路径：从SharePoint「在桌面打开」的文件，实际存储路径为本地同步的SharePoint文件夹（而非示例中的C:\Your\Path\...），需替换clientFolderPath为实际路径（可通过右键客户工作簿→属性查看）。
2. 明确工作表名称匹配校验：移除On Error Resume Next的静默错误掩盖，改用主动遍历判断工作表是否存在，避免因名称大小写/空格差异导致匹配失败。
3. 添加性能与稳定性优化：禁用屏幕更新、自动计算和事件触发，避免Excel 365后台优化干扰数据写入。

针对Excel 2019的核心修复 #

1. 修复最后一行计算逻辑：原代码中lastRowMonthly仅在处理每个客户工作表时计算一次，后续追加会覆盖已有数据；改为每次写入前重新计算目标工作表的最后一行。
2. 避免重复数据写入：增加数据重复校验，防止后续运行时重复追加相同记录。
3. 完善对象资源释放：循环结束后彻底释放所有对象，避免内存泄漏导致后续运行失效。

修改后的完整VBA代码 #

Sub ConsolidateClientData()
    Dim wsCounselor As Worksheet, clientWs As Worksheet
    Dim clientWB As Workbook, monthlyWB As Workbook
    Dim clientFolderPath As String, fileName As String
    Dim cWsName As String
    Dim lastRowMonthly As Long, i As Long, targetRow As Long
    Dim dayService As Range, milesTraveled As Range, hoursTraveled As Range
    Dim clientName As String, typeService As String
    Dim sheetExists As Boolean
    
    ' --------------------------
    ' 替换为你的SharePoint同步路径
    ' --------------------------
    clientFolderPath = "C:\Users\YourName\SharePoint\YourTeamSite\Documents\ClientWorkbooks\"
    
    ' 绑定月度工作簿
    Set monthlyWB = ThisWorkbook
    
    ' 性能优化：禁用屏幕更新、自动计算与事件
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 遍历客户文件夹中的所有xlsx文件
    fileName = Dir(clientFolderPath & "*.xlsx")
    
    Do While fileName <> ""
        Set clientWB = Workbooks.Open(clientFolderPath & fileName, ReadOnly:=True)
        
        For Each clientWs In clientWB.Sheets
            cWsName = clientWs.Name
            sheetExists = False
            
            ' 主动校验月度工作簿中是否存在对应工作表
            For Each wsCounselor In monthlyWB.Sheets
                If UCase(wsCounselor.Name) = UCase(cWsName) Then
                    sheetExists = True
                    Exit For
                End If
            Next wsCounselor
            
            If Not sheetExists Then
                Debug.Print "未找到匹配工作表: " & cWsName
                GoTo NextSheet
            End If
            
            ' 获取客户与服务信息
            clientName = clientWs.Range("C6").Value
            typeService = clientWs.Range("F2").Value
            
            ' 绑定数据范围
            Set dayService = clientWs.Range("A11:A22")
            Set milesTraveled = clientWs.Range("K11:K22")
            Set hoursTraveled = clientWs.Range("F11:F22")
            
            ' 遍历每日数据
            For i = 1 To dayService.Cells.Count
                If dayService.Cells(i).Value <> "" Then
                    ' 每次写入前重新计算最后一行
                    lastRowMonthly = wsCounselor.Cells(wsCounselor.Rows.Count, "A").End(xlUp).Row
                    targetRow = lastRowMonthly + 1
                    
                    ' 重复数据校验：检查是否已存在相同的日服务+客户记录
                    If wsCounselor.Range("A:A").Find(dayService.Cells(i).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing _
                        Or wsCounselor.Range("B:B").Find(clientName, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
                        
                        ' 写入数据
                        wsCounselor.Cells(targetRow, 1).Value = dayService.Cells(i).Value
                        wsCounselor.Cells(targetRow, 2).Value = clientName
                        wsCounselor.Cells(targetRow, 3).Value = typeService
                        wsCounselor.Cells(targetRow, 4).Value = milesTraveled.Cells(i).Value
                        wsCounselor.Cells(targetRow, 5).Value = hoursTraveled.Cells(i).Value
                    End If
                End If
            Next i
            
NextSheet:
            Set wsCounselor = Nothing
        Next clientWs
        
        ' 关闭客户工作簿（只读打开无需保存）
        clientWB.Close SaveChanges:=False
        fileName = Dir
    Loop
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "数据汇总完成"
End Sub

内容的提问来源于stack exchange，提问作者Andrew McDaniel