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

Set操作中基本缺少Workbooks，因此未初始化文件句柄，因此所有后续文件操作均失败。如果您尝试使用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

我觉得循环打开许多新文件可能还有其他问题。我将以这种方式组合最后三个循环，以减少同时打开的文件的数量：

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进行冗余操作也不错。

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

1 个答案: