将来自多个工作簿的数据组合到单个工作表中

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个单独的工作簿，每个工作簿有一个工作表，每个工作表都有不同的行数，但列的确切数量( all ))被复制到新创建的工作簿的单个工作表中(连续复制)。我收到了一个

运行时错误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