VBA reDim 保留 2D Arrays 保持失敗

Question

我看過一些帖子說你只能在reDim中重新調整多維數組的最后一維。

這種情況有什么解決辦法嗎？

Sub test()
    Dim arr As Variant
    Dim i As Long
    Dim j As Long
        
    For i = 1 To 10
        For j = 1 To 10
            ReDim Preserve arr(1 To i, 1 To j)
            arr(i, j) = i
        Next j
    Next i
End Sub

對於電子表格，二維數組的第一個維度是行，第二個維度是列。

需要將一行或一列添加到我們正在處理的數據中，這不是很常見的情況嗎？

---

更多解釋：

我的項目需要加載 10 個工作簿，每個 wb 都有未知數量的工作表和未知的數據行。

我正在嘗試加載所有這些，將它們全部放入一個二維數組中，因為它們共享相同的結構，根據它們來自哪個文檔和工作表，在每一行之前添加了一些列。

這就是為什么我必須重新調整兩個維度。

Answer 1

為簡單起見，以下代碼僅組合活動工作簿中每個工作表的數據。 但是，也可以對其進行修改以包括其他工作簿。

代碼循環遍歷活動工作簿中的每個工作表。 對於每個工作表，它遍歷每一行，不包括 header 行。 對於每一行，數據首先傳輸到一個數組，然后添加到一個集合中。 然后將集合中的組合數據傳輸到另一個數組。 最后，數組的內容被傳輸到新創建的工作表中。

同樣，為簡單起見，我假設每張工作表的數據僅包含兩列。 所以我將currentRow()聲明為1-Row by 4-Column數組。 前兩列將存儲工作表數據，第三和第四列將存儲相應的工作簿名稱和工作表名稱。 您需要相應地更改第二個維度。

Option Explicit

Sub CombineAllData()

    Dim sourceWorkbook As Workbook
    Dim currentWorksheet As Worksheet
    Dim newWorksheet As Worksheet
    Dim currentData() As Variant
    Dim currentRow(1 To 1, 1 To 4) As Variant
    Dim allData() As Variant
    Dim col As Collection
    Dim itm As Variant
    Dim i As Long
    Dim j As Long
    
    Set col = New Collection
    
    Set sourceWorkbook = ActiveWorkbook
    
    For Each currentWorksheet In sourceWorkbook.Worksheets
    
        'get the data from the current worksheet
        currentData = currentWorksheet.Range("a1").CurrentRegion.Value
        
        'add each row of data to the collection, excluding the header row
        For i = LBound(currentData) + 1 To UBound(currentData)
            For j = 1 To 2
                currentRow(1, j) = currentData(i, j)
            Next j
            currentRow(1, 3) = sourceWorkbook.Name
            currentRow(1, 4) = currentWorksheet.Name
            col.Add currentRow
        Next i
        
    Next currentWorksheet
    
    'resize the array to store the combined data
    ReDim allData(1 To col.Count, 1 To 4)
    
    'transfer the data from the collection to the array
    With col
        For i = 1 To .Count
            For j = 1 To 4
                allData(i, j) = .Item(i)(1, j)
            Next j
        Next i
    End With
    
    'add a new worksheet to the workbook
    Set newWorksheet = Worksheets.Add
    
    'transfer the contents of the array to the new worksheet
    newWorksheet.Range("a1").Resize(UBound(allData), UBound(allData, 2)).Value = allData
    
End Sub

Answer 2

堆棧范圍

• 為簡單起見，假設數據以單元格A1開頭，它是表格格式（一行標題，沒有空行或列）並且數據范圍至少有兩個單元格。
• 此外，假定該文件夾僅包含源文件。

Sub StackRanges()

    Const sFolderPath As String = "C:\Test\"
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim scoll As Collection: Set scoll = New Collection
    
    Application.ScreenUpdating = False
    
    Dim fsoFile As Object, swb As Workbook, sws As Worksheet
    Dim srCount As Long, scCount As Long, drCount As Long, dcCount As Long
    
    For Each fsoFile In fso.GetFolder(sFolderPath).Files
        Set swb = Workbooks.Open(fsoFile.Path, True, True)
        For Each sws In swb.Worksheets
            With sws.Range("A1").CurrentRegion
                srCount = .Rows.Count - 1 ' lose the header
                If srCount > 0 Then
                    scoll.Add .Resize(srCount).Offset(1).Value
                    drCount = drCount + srCount ' total
                    scCount = .Columns.Count
                    If scCount > dcCount Then dcCount = scCount ' max
                End If
            End With
        Next sws
        swb.Close SaveChanges:=False
    Next fsoFile
    
    If scoll.Count = 0 Then Exit Sub

    Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
     
    Dim sItem, sr As Long, dr As Long, c As Long
    
    For Each sItem In scoll
        For sr = 1 To UBound(sItem, 1)
            dr = dr + 1
            For c = 1 To UBound(sItem, 2)
                dData(dr, c) = sItem(sr, c)
            Next c
        Next sr
    Next sItem

    ' Write the values from the array to a new single-worksheet workbook.
'    With Workbooks.Add(xlWBATWorksheet)
'        .Worksheets(1).Range("A2").Resize(drCount, dcCount).Value = dData
'        .Saved = True ' to close without confirmation
'    End With

    Application.ScreenUpdating = True
    
    MsgBox "Ranges stacked.", vbInformation

End Sub