Add multiple range to a 2 dimensional array

[ashish128]

Dear All,

Am trying to write VBA code to make a 2 dimensional array from different ranges but unable to properly insert second and next ranges.

My ranges are on Col A to Col H on each sheet with possibility of different total number of rows on different sheets.

Sub ticker()
'
' ticker Macro
' This macro will consider all Sheets

'
    Dim thisWB As Workbook
    Dim thisWS As Worksheet
    Dim lastrow As Long
    Dim tickerArray As Variant
    
    Set thisWB = ActiveWorkbook
    counter = 1
    For Each thisWS In thisWB.Worksheets
        
        lastrow = thisWS.Cells(thisWS.Rows.Count, 1).End(xlUp).Row
        'Add data to array
        If counter = 1 Then
            ReDim tickerArray(1 To lastrow - 1, 1 To 8)
            tickerArray = thisWS.Range("A2:H" & lastrow)
            
            
        Else
            
            tickerArray = Application.Transpose(tickerArray)
            ReDim Preserve tickerArray(1 To 8, 1 To UBound(tickerArray, 2) + lastrow - 1)
            tickerArray = Application.Transpose(tickerArray)
            'Am not able to append the range to array below. the current code in below line replaces the array values
            tickerArray = thisWS.Range("A2:H" & lastrow)
            
        End If
        
        counter = counter + 1
    Next thisWS
    
End Sub

Data on each sheet looks like below

<ticker>	<date>	<open>	<high>	<low>	<close>	<vol>	Calculate
AAB	20200102	23.43​	23.57​	23.43​	23.57​	28522​
AAB	20200103	23.52​	23.61​	23.43​	23.44​	1399​
AAB	20200106	23.46​	23.48​	23.37​	23.39​	2953​
AAB	20200107	23.31​	23.47​	23.28​	23.47​	64755​

Could you please guide me as to where should I correct my code?
I know I need to insert second range after the first range but am unable to make a code for it.

Best Regards
Ashish

 

[bebo021999]

Why not loop every row thoughout every worksheets?
with this:

ReDim Preserve tickerArray(1 To 8, 1 To UBound(tickerArray, 2) + lastrow - 1)
            tickerArray = Application.Transpose(tickerArray)
            tickerArray = thisWS.Range("A2:H" & lastrow)

the ticketArray is overwriten with the last sheet range.

 

[ashish128]

Why not loop every row thoughout every worksheets?
with this:

ReDim Preserve tickerArray(1 To 8, 1 To UBound(tickerArray, 2) + lastrow - 1)
            tickerArray = Application.Transpose(tickerArray)
            tickerArray = thisWS.Range("A2:H" & lastrow)

the ticketArray is overwriten with the last sheet range.

Thanks for the response,

Am trying to learn to add worksheet ranges to an array and hence this approach.

I know my current approach has flaw and it overwrites the existing data and this is why am asking for help.

I need to know how to add a workbook range to an array which has been Redim and Preserved. I just do not know how to add the range so that it does not overwrite.

Regards
Ashish

 

[ashish128]

Update:
When I try to modify the code like below line then it runs but the array structure gets strange.

Note: 5 is the last row of data in array in first loop (taken from sheet).

tickerArray(totalrow + 1, 1) = thisWS.Range("A2:H" & lastrow)

slim VBA Assignment.xlsm
	A
2	AAB
A

 

[ashish128]

slim VBA Assignment.xlsm
	A	B	C	D	E	F	G	H
1	<ticker>	<date>	<open>	<high>	<low>	<close>	<vol>	Date
2	AAB	20200102	23.43	23.57	23.43	23.57	28522	02 January 2020
3	AAB	20200103	23.52	23.61	23.43	23.44	1399	03 January 2020
4	AAB	20200106	23.46	23.48	23.37	23.39	2953	06 January 2020
5	AAB	20200107	23.31	23.47	23.28	23.47	64755	07 January 2020
A

Cell Formulas
Range	Formula
H2:H5	H2	=DATE(LEFT(B2,4),MID(B2,5,2),RIGHT(B2,2))

 

[Trebor76]

Hi ashish128,

What about this where the size of the array is set at the start and then populated so there's no need for using Preserve which is not smooth sailing for Two-Dimensional Arrays:

Option Explicit
Sub Macro1()

    Dim vArr As Variant
    Dim i As Long, j As Long, k As Long, x As Long
    Dim lngTotalRows As Long, lngTotalCols As Long
    Dim ws As Worksheet
    Dim strOutputTab As String
    
    Application.ScreenUpdating = False
    
    strOutputTab = "Sheet4" 'Sheet name for the array output. Change to suit.
    
    'Set the dynamic total number of rows for the 'vArr' array
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            lngTotalRows = lngTotalRows + ws.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
        End If
    Next ws
    'Set the static (could be dynamic like above) total number of columns for the 'vArr' array
    lngTotalCols = 8
    
    'Set the required row and column ranges for the 'vArr' array
    ReDim vArr(1 To lngTotalRows, 1 To lngTotalCols)
    
    'Populate the 'vArr' array
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            j = ws.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For i = 2 To j
                k = k + 1
                For x = 1 To lngTotalCols
                    vArr(k, x) = ws.Cells(i, x)
                Next x
            Next i
        End If
    Next ws

    'Output 'vArr' array
    ThisWorkbook.Sheets(strOutputTab).Range("A2").Resize(UBound(vArr, 1), lngTotalCols) = vArr
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Trebor76]

On review I came up with this where everything is transposed until just before the vArr is outputted where the array is then transposed again so we get rows and columns:

Option Explicit
Sub Macro2()

    'https://www.mrexcel.com/board/threads/add-multiple-range-to-a-2-dimensional-array.1216337
 
    Const lngTotalCols As Long = 8 'Number of columns in dataset. Change to suit.
    Const lngStartRow As Long = 2 'Starting row for the data across all tabs. Change to suit.
 
    Dim vArr As Variant
    Dim i As Long, j As Long, k As Long, x As Long
    Dim ws As Worksheet
    Dim strOutputTab As String
 
    Application.ScreenUpdating = False
 
    strOutputTab = "Sheet4" 'Sheet name for the array output. Change to suit.
 
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            j = ws.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If IsEmpty(vArr) Then
                ReDim vArr(1 To lngTotalCols, 1 To j - (lngStartRow - (lngStartRow - 1)))
            Else
                ReDim Preserve vArr(1 To lngTotalCols, 1 To CLng(UBound(vArr, 2) + j - (lngStartRow - (lngStartRow - 1))))
            End If
            For i = lngStartRow To j 'Not sure why simply a range instead of looping can't be added here
                x = x + 1
                For k = 1 To lngTotalCols
                    vArr(k, x) = Application.Transpose(ws.Cells(i, k))
                Next k
            Next i
        End If
    Next ws
 
    vArr = Application.Transpose(vArr)
 
    ThisWorkbook.Sheets(strOutputTab).Range("A2").Resize(UBound(vArr, 1), lngTotalCols) = vArr
 
    Application.ScreenUpdating = True

End Sub

I couldn't get it to work where a range like A2:H10 is used to append to the vArr array as it kept getting overwritten with the last range. If anyone here can provide a solution for that I'd be keen to see it.

Regards,

Robert

 

[ashish128]

Hi ashish128,

What about this where the size of the array is set at the start and then populated so there's no need for using Preserve which is not smooth sailing for Two-Dimensional Arrays:

Option Explicit
Sub Macro1()

    Dim vArr As Variant
    Dim i As Long, j As Long, k As Long, x As Long
    Dim lngTotalRows As Long, lngTotalCols As Long
    Dim ws As Worksheet
    Dim strOutputTab As String
   
    Application.ScreenUpdating = False
   
    strOutputTab = "Sheet4" 'Sheet name for the array output. Change to suit.
   
    'Set the dynamic total number of rows for the 'vArr' array
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            lngTotalRows = lngTotalRows + ws.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
        End If
    Next ws
    'Set the static (could be dynamic like above) total number of columns for the 'vArr' array
    lngTotalCols = 8
   
    'Set the required row and column ranges for the 'vArr' array
    ReDim vArr(1 To lngTotalRows, 1 To lngTotalCols)
   
    'Populate the 'vArr' array
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            j = ws.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For i = 2 To j
                k = k + 1
                For x = 1 To lngTotalCols
                    vArr(k, x) = ws.Cells(i, x)
                Next x
            Next i
        End If
    Next ws

    'Output 'vArr' array
    ThisWorkbook.Sheets(strOutputTab).Range("A2").Resize(UBound(vArr, 1), lngTotalCols) = vArr
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Dear Robert,

Thanks for your suggestion, the code and your time .

However, I know I can calculate the size of array beforehand and hence can remove the redim preserve from code but my query is about using a range to append to an array (i.e. without using a loop for each cell.)

Am looking for a solution where am not required to loop individual through cells and can directly append a range to a 2D array.

This is for my knowledge purpose only and is not hampering any project of mine. Am simply curious to go this path because I think this is possible.

Thanks again.

Best Regards
Ashish

 

[Trebor76]

Am looking for a solution where am not required to loop individual through cells and can directly append a range to a 2D array.

As I said, try as I might I couldn't the ranges to append to the vArr array. Hopefully someone in the forum can provide a solution.

 

[Trebor76]

As an alternative have a look at this which uses a Collection to consolidate all the data:

Option Explicit
Sub Macro3()

    'Based on mikerickson's post from here:
    'https://forum.ozgrid.com/forum/index.php?thread/104793-loading-multi-dimensional-array-from-ranges

    Const lngTotalCols As Long = 8 'Number of columns in dataset. Change to suit.
    Const lngStartRow As Long = 2 'Starting data row number across all tabs. Change to suit.

    Dim clnSheetValues As New Collection
    Dim ws As Worksheet
    Dim i As Long, j As Long, x As Long
    Dim strOutputTab As String
    
    Application.ScreenUpdating = False
    
    strOutputTab = "Sheet4" 'Change to suit.
    
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            i = ws.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            clnSheetValues.Add Item:=ws.Range("A" & lngStartRow & ":H" & i).Value, Key:=CStr(ws.Name)
        End If
    Next ws
    
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> strOutputTab Then
            For i = 1 To UBound(clnSheetValues(CStr(ws.Name)))
                x = IIf(x = 0, lngStartRow, x + 1)
                For j = 1 To lngTotalCols
                    ThisWorkbook.Sheets(strOutputTab).Range("A" & x).Offset(0, j - 1).Value = clnSheetValues(CStr(ws.Name))(i, j)
                Next j
            Next i
        End If
    Next ws
    
    Application.ScreenUpdating = True
    
End Sub