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张纸，所有的行数不同，但列数（AL）准确）复制到一张纸上新创建的工作簿（连续复制）。我收到

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

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

1 个答案: