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

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 dokumenter\Nedlastinger\Rapporter\"
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)

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

Array Loop that adds more and more data for each loop

arrays

excel

vba

loops

copy-paste