将多个工作簿中的数据合并到一个工作表中

Question

我的代码旨在允许用户打开多个工作簿并将每个工作簿中的数据复制到一个新工作簿中，并将该工作簿以动态名称保存在指定位置。

当数据从打开的工作簿复制到新工作簿时，我的代码失败。

Option Explicit
Option Base 1

Sub ConslidateWorkbooks()

Dim Filename As Variant, nw As Integer
Dim i As Integer, A() As Variant
Dim tWB As Workbook, aWB As Workbook, nWB As Workbook
Dim Sheet As Worksheet
Dim strFullname As String

Set tWB = ThisWorkbook
strFullname = "G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Raw Files\" & "Raw File - " & Range("PB") & Format(Range("CurrentDate"), "mmddyy") & ".csv"


Filename = Application.GetOpenFilename(FileFilter:="Excel Filter(*.csv), *.csv", Title:="Open File(s)", MultiSelect:=True)

'Application.ScreenUpdating = False

nw = UBound(Filename)
ReDim A(nw)
    For i = 1 To nw
        Workbooks.Open Filename(i)
        Set aWB = ActiveWorkbook
        A(i) = aWB.Sheets(1).Range("A6:L" & Cells(Rows.Count, 2).End(xlUp).Row)
        aWB.Close SaveChanges:=False

    Next i

Set nWB = Workbooks.Add
nWB.Activate
nWB.Sheets(1).Range("A1:L" & Cells(Rows.Count, 2).End(xlUp).Row) = WorksheetFunction.Transpose(A)
nWB.SaveAs Filename:=strFullname, FileFormat:=xlCSV, CreateBackup:=True
nWB.Close

'Application.ScreenUpdating = True

End Sub

我期望将每个工作簿中的数据（我的测试用例是 4 个单独的工作簿，每个工作簿都有 1 张工作表，所有工作簿都有不同的行数，但确切的列数 (A-L)）被复制到一个工作表中新创建的工作簿（连续复制）。 我收到了一个

运行时错误 13 类型不匹配

在以下代码行：

nWB.Sheets(1).Range("A1:L" & Cells(Rows.Count, 2).End(xlUp).Row) = WorksheetFunction.Transpose(A)

Answer 1

类似这样的：

Sub ConslidateWorkbooks()

    Dim Filename As Variant, nw As Long
    Dim i As Long, A() As Variant
    Dim tWB As Workbook, aWB As Workbook, nWB As Workbook, wb As Workbook
    Dim Sheet As Worksheet, arr
    Dim strFullname As String

    Set tWB = ThisWorkbook

    'all the ranges here should have workbook/worksheet qualifiers...
    strFullname = "G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & _
               Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Raw Files\" & _
               "Raw File - " & Range("PB") & Format(Range("CurrentDate"), "mmddyy") & ".csv"


    Filename = Application.GetOpenFilename(FileFilter:="Excel Filter(*.csv), *.csv", _
                                           Title:="Open File(s)", MultiSelect:=True)

    nw = UBound(Filename)
    ReDim A(1 To nw) 'specify lower bound

    For i = 1 To nw
        Set aWB = Workbooks.Open(Filename(i))
        With aWB.Sheets(1)
            A(i) = .Range("A6:L" & .Cells(.Rows.Count, 2).End(xlUp).Row)
            .Parent.Close SaveChanges:=False
        End With
    Next i

    Set nWB = Workbooks.Add()

    With nWB.Sheets(1)
        'loop over the A array, and add each contained array to the sheet
        For i = 1 To nw
            arr = A(i)
            .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0).Resize( _
                          UBound(arr, 1), UBound(arr, 2)).Value = arr
        Next i
        .Rows(1).Delete 'remove empty first row
    End With

    nWB.SaveAs Filename:=strFullname, FileFormat:=xlCSV, CreateBackup:=True
    nWB.Close False

End Sub