VBA reDim Preserve 2D Arrays keep failling-CodePudding

I've read some posts saying that you can only reDim the last dimention of a multi-dimensional array in VBA.

Is there any work around for such a case?

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

For a spreadsheet, the 1st dimension of 2D array is row, and the 2nd dimesion is column.

Isn't it a very commond case to be in-need to add either a row or a column into the data we are working with?

Some more explanation:

My project requires to load like 10 workbooks, and each wb has an unknown number of sheets with unknown rows of Data.

I am trying to load all of them, put them all into one 2D array since they share the same structure, added some columns ahead of each row according to which doc and sheet they came from.

That is why I have to reDim both dimensions.

CodePudding user response：

For simplicity, the following code only combines the data from each worksheet in the active workbook. However, it can be amended to include other workbooks as well.

The code loops through each worksheet in the active workbook. For each worksheet, it loops through each row, excluding the header row. For each row, the data is first transferred to an array, and then added to a collection. Then the combined data from the collection is transferred to another array. And, lastly, the contents of the array is transferred to a newly created worksheet.

Again, for simplicity, I have assumed that the data for each sheet contains only two columns. So I have declared currentRow() as a 1-Row by 4-Column array. The first two columns will store the worksheet data, and the third and fourth columns will store the corresponding workbook name and sheet name. You'll need to change the second dimension accordingly.

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

CodePudding user response：

Stack Ranges

For simplicity, it is assumed that the data starts with cell A1, that it is in table format (one row of headers, no empty rows or columns) and the data ranges have at least two cells.
Also, it is assumed that the folder contains nothing but the source files.

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