我使用的是一段时间前在此网站上找到的以下代码。代码正在按输入运行。
ws1是成本中心的唯一列表ws2是针对成本中心的长期冗长的数据表。
我要这段代码要做的是，找到与ws2上ws1上的第一个代码相关的所有成本，并将其粘贴到第三张表（模板）中，然后我有将该表转换成该成本中心报告的代码，然后清除其内容。
然后我希望代码继续并在ws2上的下一个代码中找到它们，然后粘贴到第三张表中，这样我就可以创建报告，依此类推等等。
ws2上有65000条记录，所有记录都与26个ish成本中心ws1之一相关。
Option Explicit
Sub createReports()
Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
Dim i As Long, j As Long
ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange
ReDim ws3(11, 0)
For i = 1 To UBound(ws1)
For j = 1 To UBound(ws2)
If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
ReDim Preserve ws3(11, Count)
ws3(0, Count) = ws2(j, 1)
ws3(1, Count) = ws2(j, 2)
ws3(2, Count) = ws2(j, 3)
ws3(3, Count) = ws2(j, 4)
ws3(4, Count) = ws2(j, 5)
ws3(5, Count) = ws2(j, 6)
ws3(6, Count) = ws2(j, 7)
ws3(7, Count) = ws2(j, 8)
ws3(8, Count) = ws2(j, 9)
ws3(9, Count) = ws2(j, 10)
ws3(10, Count) = ws2(j, 11)
Count = Count + 1
End If
Next j
Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
Call createWrkBooks
Call clearContents
Next i
Set ws1 = Nothing
Set ws2 = Nothing
End Sub
当前，代码运行，但是从ws2复制所有数据，但按成本中心的顺序将行分组在一起。
我想要做的是创建26个单独的报告，所有报告都首先复制到模板中，其他代码将另存为工作簿，然后清除内容。准备重新填充。
答案 0 :(得分：1)
以下应该起作用。您只需要为每个Count重新初始化ws3和i。否则，您会将新数据附加到旧数据上。
're-initialize for the next i
ReDim ws3(11, 0) 'needs to be inside the For i loop
Count = 0
Option Explicit
Sub createReports()
Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
Dim i As Long, j As Long
ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange
For i = 1 To UBound(ws1)
're-initialize for the next i
ReDim ws3(11, 0) 'needs to be inside the For i loop
Count = 0
'collect everything for the current i
For j = 1 To UBound(ws2)
If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
ReDim Preserve ws3(11, Count)
ws3(0, Count) = ws2(j, 1)
ws3(1, Count) = ws2(j, 2)
ws3(2, Count) = ws2(j, 3)
ws3(3, Count) = ws2(j, 4)
ws3(4, Count) = ws2(j, 5)
ws3(5, Count) = ws2(j, 6)
ws3(6, Count) = ws2(j, 7)
ws3(7, Count) = ws2(j, 8)
ws3(8, Count) = ws2(j, 9)
ws3(9, Count) = ws2(j, 10)
ws3(10, Count) = ws2(j, 11)
Count = Count + 1
End If
Next j
'save the current i colleted data
Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
Call createWrkBooks
Call ClearContents
Next i
Set ws1 = Nothing
Set ws2 = Nothing
End Sub
答案 1 :(得分：1)
您尚未声明count。使用Option Explicit可以避免这种情况。
Option Explicit
此版本现在应该可以使用。
Sub createReports0B()
Const cRows As Long = 10
Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
Dim i As Long, j As Long, k As Long
Dim count As Long
ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange
For i = 1 To UBound(ws1)
count = 0
ReDim ws3(cRows, count)
For j = 1 To UBound(ws2)
If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
ReDim Preserve ws3(cRows, count)
For k = 0 To cRows
ws3(k, count) = ws2(j, k + 1)
Next k
count = count + 1
End If
Next j
Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
Call createWrkBooks
Call ClearContents
Next i
End Sub
我本来应该使用基于1的数组，因为它可以更快地转移到一个范围内（无循环）。
Sub createReports1B()
Const cRows As Long = 11
Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
Dim i As Long, j As Long, k As Long
Dim count As Long
ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange
For i = 1 To UBound(ws1)
count = 1
ReDim ws3(1 To cRows, 1 To count)
For j = 1 To UBound(ws2)
If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
ReDim Preserve ws3(1 To cRows, 1 To count)
For k = 1 To cRows
ws3(k, count) = ws2(j, k)
Next k
count = count + 1
End If
Next j
' You have to change here because ws3 is a 1B 2D array.
Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
Call createWrkBooks
Call ClearContents
Next i
End Sub