数组循环，为每个循环添加越来越多的数据

Question

得到这个VBA：

Sub HenteDataFraSkjema1()
Dim wbThis                  As Workbook
Dim wbTarget                As Workbook
Dim sht1 As Worksheet
Dim Data() As Variant
Dim i As Integer

Set wbThis = ActiveWorkbook
Set sht1 = wbThis.Sheets("Ark1")
Folder = "H:Mine dokumenterNedlastingerRapporter"
Fname = Dir(Folder)
Do While Fname <> ""
Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)
Set wsData = ThisWorkbook.Sheets("Ark1")

Dim DataEntry As Range
Set DataEntry = wbTarget.Sheets(1).Range("B3,G3,B7,R7")
If Len(DataEntry.Cells(1, 1).Value) > 0 Then
For Each Item In DataEntry
i = i + 1
ReDim Preserve Data(1 To i)
Data(i) = Item.Value
Next

wsData.Cells(wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(1, i).Value = Data

End If

Fname = Dir
wbTarget.Close True

Loop
End Sub

我正在尝试扫描文件夹中的所有文件(250个！(，将B3、G3、B7、R7中的数据复制到文件中，并将数据粘贴到A1、B1、C1、D1中的wbThis中。wbThis中的下一个文件在下一个可用行中。VBA复制还可以，但每次运行的数据都会累积起来。在2号文件中，它将数据粘贴到wbThis中的单元格B2、B2、C2、D2、E2、F2、G2、H2中。B2:D2中的数据与从1号文件复制的数据相同。发生了什么？我该如何阻止数组执行此操作？

Answer 1

您的变量i永远不会重置为零，因此对于您打开的每个新工作簿，它只会向同一数组添加越来越多的数据。

就在循环结束之前，插入这些行；

ReDim Data(1 to 1) '  Empties current data from the array, so it won't get re-used
i = 0              '  Empties the i variable so next sheet's data gets copied to 
'    the correct columns (starting at column A)