VBA运行时错误'-2147221080'：合并200个Excel文件失败求助

我需要编写代码将200个Excel文件合并为单个文档，这些文件的表头和数据结构一致，数据均位于名为“ms”的工作表中。主工作簿内有一个空白的“mb”工作表，目标是把“All”文件夹中所有工作簿的数据复制到该表中。但原代码在ws.Cells.Copy行触发VBA运行时错误'-2147221080 (800401a8)'（自动化错误）。

原错误代码 #

Sub CombineData()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim myPath As String
    Dim myFile As String

    myPath = "C:\Users\d.pavlov\Documents\All"

    Set ws = ActiveWorkbook.Sheets("ms")

    '指定主工作表
    Set wsMaster = Workbooks("Master Workbook.xlsx").Sheets("mb")

    lastRow = wsMaster.Cells(Rows.Count, 1).End(xlUp).Row

    myFile = Dir(myPath & "\*.xlsx")

    Do While myFile <> ""
        Set wb = Workbooks.Open(Filename:=myPath & "\" & myFile)
        ws.Cells.Copy
        wsMaster.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
        wb.Close False
        lastRow = wsMaster.Cells(Rows.Count, 1).End(xlUp).Row
        myFile = Dir
    Loop
End Sub

原代码核心问题：

• 提前在循环外设置ws = ActiveWorkbook.Sheets("ms")，打开新工作簿后未重新引用对应工作簿的“ms”工作表
• 直接复制整个工作表的Cells范围，处理大量文件时易触发自动化错误

可行解决方案代码 #

以下代码可正常运行并完成合并需求，同时支持自定义采集范围、工作表名称筛选、粘贴方式选择等功能：

'Option Explicit
 
Sub Consolidated_Range_of_Books_and_Sheets()
    Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles
    Dim wbAct As Workbook
    Dim bPasteValues As Boolean, IsPasteSheetName As Boolean
 
    On Error Resume Next
    '选择数据采集范围
    Set iBeginRange = Application.InputBox("选择数据采集范围。" & vbCrLf & _
"1. 若仅选择单个单元格，将从该单元格开始采集所有数据" & _
vbCrLf & "2. 若选择多个单元格，仅采集指定范围的数据", Type:=8)
'无需弹窗指定范围的话，可替换为下面一行：
'Set iBeginRange = Range("A1") '根据需要设置范围
'若未选择范围，退出程序
If iBeginRange Is Nothing Then
        Exit Sub
    End If
    '指定工作表名称
'允许使用?和*通配符，输入*则采集所有工作表的数据
    sSheetName = InputBox("输入要采集数据的工作表名称（留空则采集所有工作表）", "参数设置")
    '若未指定工作表名称，采集所有工作表
    If sSheetName = "" Then
        sSheetName = "*"
    End If
'是否在表格开头添加工作表名称列
    IsPasteSheetName = (MsgBox("是否在表格首列插入工作表名称？", vbQuestion + vbYesNo) = vbYes)
    On Error GoTo 0
'选择粘贴方式：仅粘贴值，还是粘贴全部数据（含公式、格式等）
    bPasteValues = (MsgBox("是否仅粘贴值？", vbQuestion + vbYesNo) = vbYes)
    '选择数据来源：多个工作簿还是当前工作簿
    If MsgBox("是否从多个工作簿采集数据？", vbInformation + vbYesNo) = vbYes Then
        avFiles = Application.GetOpenFilename("Excel文件(*.xls*),*.xls*", , "选择文件", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 1
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If
    If IsPasteSheetName Then
        lCol = lCol + 1
    End If
    '关闭屏幕刷新、自动计算和事件触发，提升运行速度并避免错误
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
    '新建工作表用于存放合并后的数据
    Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    '若要将数据存放在代码所在工作簿的新表，可替换为下面一行：
'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'遍历所选工作簿
    For li = LBound(avFiles) To UBound(avFiles)
        If bPolyBooks Then
            Set wbAct = Workbooks.Open(Filename:=avFiles(li))
        Else
            Set wbAct = ThisWorkbook
        End If
        oAwb = wbAct.Name
'遍历工作簿中的工作表
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                '若当前工作表是存放数据的表且仅从当前工作簿采集，跳过
                If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                With wsSh
                    Select Case iBeginRange.Count
                    Case 1 '从指定单元格开始采集所有数据
                        lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
                        iLastColumn = .Cells.SpecialCells(xlLastCell).Column
                        sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
                    Case Else '采集指定固定范围的数据
                        sCopyAddress = iBeginRange.Address
                    End Select
                    lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
                    '仅复制工作表中已使用的有效数据范围
                    Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress))
                    '插入数据来源工作簿名称
                    If lCol > 0 Then
                        If bPolyBooks Then
                            wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb
                        End If
                        '插入数据来源工作表名称
                        If IsPasteSheetName Then
                            wsDataSheet.Cells(lLastRowMyBook, lCol).Resize(rCopy.Rows.Count).Value = .Name
                        End If
                    End If
                   '仅粘贴值和格式
                    If bPasteValues Then
                        rCopy.Copy
                        wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
                        wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats
                    Else '粘贴全部数据（含公式、格式等）                        
                        rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                    End If
                End With
            End If
NEXT_:
        Next wsSh
        If bPolyBooks Then
            wbAct.Close False
        End If
    Next li
    '恢复屏幕刷新、自动计算和事件触发
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lCalc
    End With
End Sub

内容的提问来源于stack exchange，提问作者Денис Павлов