以编程方式创建文档并在 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并不坏。