Search code examples
arraysexcelvbadynamic-arrays

Making one Array composed of multiple range values from different sheets in Excel VBA

I'm trying to create an array of values which I obtain from x many sheets that a data spreadsheet has.

Currently this is what I have so far 


Sub Test()

Workbooks.Open("dataex.xlsx").Activate
Dim i, x, y, z, sheet_num

Dim allsheets As Variant

Dim sheet As Variant
Dim sheets As Variant '

Dim list As Variant

Dim ws As Worksheet
i = Application.sheets.Count

x = 1
ReDim allsheets(1 To i)

For Each ws In Worksheets
    allsheets(x) = ws.Name
    x = x + 1
Next ws

sheets = allsheets
For Each sheet In sheets

tmp = Range("A2").CurrentRegion.Value

y = Range("A1").CurrentRegion.Rows.Count
z = Range("A1").CurrentRegion.Columns.Count

list = Range(Cells(1, 1), Cells(y, z))

Next sheet

End Sub

I have attached a picture to show the the fake data I created (same data on each sheet for simplicity)

enter image description here At the end I would like to get an array named list to be the same number of z columns but the rows of the values would be added underneath each other and then to resize the array and add the sheet it is from.

enter image description here

Solution

  • I've done something similar before and it looked like this:

    Sub Test()

    Dim i As Long, wb As Workbook, data(), numSheets As Long
    Dim rng As Range, numCol As Long, totRows As Long, allData()
    Dim rw As Long, col As Long, arr, r As Long, firstSheet As Boolean

    Set wb = Workbooks.Open("dataex.xlsx")
    numSheets = wb.Worksheets.Count

    ReDim data(1 To numSheets)
    firstSheet = True 'controls whether we skip the header row

    'loop over the sheets and collect the data
    For i = 1 To numSheets
        Set rng = wb.Worksheets(i).Range("A1").CurrentRegion
        'ignore empty sheets
        If Application.CountA(rng) > 0 Then
            'remove the header if not first sheet
            If Not firstSheet Then Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
            data(i) = rng.Value                     'collect the data
            totRows = totRows + UBound(data(i), 1)  'add the row count
            firstSheet = False 'done one sheet
        End If
    Next i

    'size the final output array
    ReDim allData(1 To totRows, 1 To UBound(data(1), 1))

    r = 1
    'combine the array from each sheet into the final array
    For i = 1 To numSheets
        If Not IsEmpty(data(i)) Then 'sheet had data?
            arr = data(i)
            For rw = 1 To UBound(arr, 1)
                For col = 1 To UBound(arr, 2)
                    allData(r, col) = arr(rw, col)
                Next col
                r = r + 1
            Next rw
        End If
    Next i

    'add a new sheet and dump the array
    With wb.sheets.Add(after:=wb.sheets(wb.sheets.Count))
        .Range("A1").Resize(totRows, UBound(allData, 2)).Value = allData
    End With

End Sub