VBA批量合并50个Excel工作簿指定数据功能异常求助

原代码核心问题 #

• startt、endd初始计算时变量i未正确赋值，且循环过程中没有动态更新这两个值，导致粘贴的目标区域始终无效
• 中间嵌套的无意义Do循环重复调用Dir函数，打乱了原有文件遍历的指针逻辑，导致文件遍历异常
• 不必要的工作表Select操作，容易触发运行时报错
• 新工作簿默认工作表名使用俄语名称，非俄语版本的Excel会出现找不到工作表的报错
• 多余的[A1]单元格赋值逻辑，无实际作用还可能污染活动工作表内容

修复后完整代码 #

Sub Combine()
    Dim s As String, MyFiles As String
    Dim endd As Integer, startt As Integer
    Dim NewWb As Workbook
    Dim newS As Worksheet
    Dim i As Long
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' 新建汇总工作簿，直接取第一个工作表避免名称不兼容
    Set NewWb = Workbooks.Add
    Set newS = NewWb.Worksheets(1)
    
    ' 初始化文件计数器
    i = 0
    MyFiles = "C:\Users\User\Desktop\Nezavisimai\Papka2\" ' 可替换为实际文件夹路径
    s = Dir(MyFiles & "*.xlsx")
    
    Do While s <> ""
        i = i + 1
        ' 动态计算当前文件的粘贴起始和结束行
        startt = (i - 1) * 10 + 1
        endd = i * 10
        
        ' 打开源文件复制指定区域
        With Workbooks.Open(MyFiles & s)
            .Worksheets("Данные").Range("A1:C10").Copy ' 可替换为实际工作表名和区域
            newS.Range("B" & startt).PasteSpecial Paste:=xlPasteAll ' 只粘贴值可改为xlPasteValues
            .Close SaveChanges:=False
        End With
        
        ' 清除剪贴板避免弹窗提示
        Application.CutCopyMode = False
        s = Dir
    Loop
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

使用注意事项 #

• 代码中MyFiles对应的路径需要替换为你自己存放Excel文件的实际路径
• 如果源文件中存放数据的工作表名称不是俄语的Данные，需要修改为实际的工作表名称
• 若仅需要粘贴数值不需要格式，可将xlPasteAll替换为xlPasteValues

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