vba - 在 VBA 中以编程方式创建文档并为其分配数据

Question

好的，我有一个代码块，它循环遍历事务表以查找唯一值，然后根据这些唯一值创建一个表。例如，

Lucy ~ CA ~ Likes Monty Python
Lucy ~ CA ~ Plays the Ukulele
Abby ~ FL ~ Owns a submarine

我的代码将从表中读取唯一值并创建一个名为 Lucy.xlsx 和 Abby.xlsx 的 xlsx。

我不知道该怎么做，就是获取以 Lucy 开头的值，并将它们复制到名为 Lucy.xlsx 的表中，对于工作表中的其他唯一值，依此类推.

我能够以编程方式循环浏览文件并重新打开它们。当没有任何复制时。

这是我的代码。

Sub getMetaData()
    ' EVERYTHING SEEMS TO WORK FINE RIGHT HERE '
    Dim home As Workbook
    Set home = ActiveWorkbook
    Dim sht1 As Worksheet
    Set sht1 = home.Sheets(1)

    Dim lastSheet As Integer
    lastSheet = ActiveWorkbook.Sheets.Count

    Sheets.Add After:=Sheets(lastSheet)

    lastSheet = lastSheet + 1

    ActiveWorkbook.Sheets(lastSheet).Select
    ActiveWorkbook.Sheets(lastSheet).Name = "Meta Data"
    ActiveWorkbook.Sheets(1).Select

    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long

    Set sht = ActiveWorkbook.Sheets(1)
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    lastColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column

    Dim DirArray As Variant
    DirArray = sht.Range(Cells(2, 1), Cells(lastRow, 1)).Value

    Dim arr As New Collection, a
    Dim aFirstArray() As Variant
    Dim i As Long

    aFirstArray() = DirArray

    On Error Resume Next
    For Each a In aFirstArray
        arr.Add a, a
    Next

    Sheets("Meta Data").Select

    For i = 1 To arr.Count
        Cells(i, 1) = arr(i)
    Next

    lastArea = arr.Count
    Dim whyArray() As Variant
    ReDim Preserve whyArray(1 To (lastArea))
    MyPath = ActiveWorkbook.Path

    For i = 1 To lastArea
        whyArray(i) = Cells(i, 1)
    Next i

    Dim wb() As Workbook
    ReDim Preserve wb(lastArea)

    For i = 1 To lastArea
        Cells(i, 25) = "Whoop dey it is"
        Cells(i, 26) = whyArray(i)
    Next i

    For i = 1 To lastArea
        wb(i) = Workbooks.Add
        ActiveWorkbook.SaveAs (whyArray(i))
        ActiveWorkbook.Close
    Next i

    Dim wbs() As Workbook
    ReDim Preserve wbs(lastArea)

    For i = 1 To lastArea
        wbs(i) = Workbooks.Open(MyPath & "\" & whyArray(i) & ".xlsx")
    Next i

    ' vvv I CAN'T GET THIS TO WORK FOR THE LIFE OF ME vvv '

    For i = 1 To lastArea
        For j = 1 To lastRow
            If whyArray(i) = sht1.Cells(j, 1).Value Then
                wbs(i).Sheets(1).Range(Cells(j, 1), Cells(j, lastColumn)).Value = sht1.Range(Cells(j, 1), Cells(j, lastColumn))
            End If
        Next j
    Next i

End Sub

Answer 1

基本上，Workbooks 操作中缺少 Set，因此文件句柄未初始化，因此所有后续文件操作都会失败。如果您尝试使用 F8 逐步运行它，您就会注意到该错误。

一些建议:您需要 On Error Resume Next 来管理按集合的过滤，但您应该在之后重置错误处理程序。您还应该检查错误是否只是预期的错误或其他错误:

Dim errnum as long
For Each a In aFirstArray
    On Error Resume Next
    arr.Add a, a
    errnum = Err.Number
    On Error Goto 0
    If errnum <> 0 and errnum <> 457 Then 
       Err.Raise errnum
       Err.Clear
    End If
Next

我觉得循环打开许多新文件可能存在其他问题。我会以这种方式组合最后 3 个循环，以减少同时打开文件的数量:

For i = 1 To lastArea
    Set wbs = Workbooks.Add(xlWBATWorksheet)
    For j = 1 To lastRow
        If whyArray(i) = sht1.Cells(j, 1).Value Then
            wbs.Sheets(1).Range(Cells(j, 1), Cells(j, lastColumn)).Value = sht1.Range(Cells(j, 1), Cells(j, lastColumn))
            Exit For
        End If
    Next j
    wbs.Close Filename:=MyPath & "\" & whyArray(i) & ".xlsx"  ' save & close
Next i

您可能会误解ReDim Preserve的用途。在声明(空)数组后立即使用 Preserve 是多余的，这也不错。