VBA how to resize array in for loop?

Question

I am trying to copy the data from another workbook by for loop. What I am going to do is looping every row in source file, if says col(1) = "USA", I will put this row into an array. After that, I would like to paste the array to the Range of my workbook. However, I keep encountering an error "subscript out of range". My 2-D array will look like [(1,2,3),(2,3,4)........].

Here is my code, what is the right step to resize the array?

Dim dataArray()    
Dim arrayIndex, endRow as Integer
endRow = Sheets("sourceSheets").Cells(Cells.Rows.Count, startCol).End(xlUp).row
arrayIndex = 1
For row = 1 To endRow
  If cell(row,1) = "USA" then
    ReDim Preserve dataArray(arrayIndex , 3) #arrayIndex will be the depth while the col is fixed as 3
    dataArray(arrayIndex, 1) = cell(row,1).value
    dataArray(arrayIndex, 2) = cell(row,2).value
    dataArray(arrayIndex, 3) = cell(row,3).value
    arrayIndex = arrayIndex +1
  end if
next

Answer 1

When you redim an array VBA will actually re-write it to a new one. When you do that hundreds of times in a loop you will have to get more coffee while you wait. The better way is to dimension the output array larger than you think you need and then cut it down to size once when you're done.

Not having time for coffee anyway you might now be in a hurry. Reading a value from the worksheet takes several times longer than reading it from an array in memory. Therefore, to save time, you copy everything into an array at the beginning and then work with that array instead of retrieving values from the sheet one by one.

The other thing to remember is that you can only redim the last dimension of a 3-D array. So, when you copy the values of a range you get an array, like, Arr([Row], [Column]). But since you need to redim not the columns but the rows the output array must transscribe values to an array like OutArr([Column], [Row]). Then, when you paste this array to the sheet you need to transpose it.

And here is the code that puts it all into action.

Sub TestArray()

    Const FirstDataRow  As Long = 2
    Const FirstClm      As String = "A"
    Const NumClms       As Long = 3
    
    Dim SrcArr          As Variant                  ' source
    Dim OutArr          As Variant                  ' output
    Dim ArrIdx          As Long
    Dim R               As Long
    Dim C               As Long
    
    With Worksheets("sourceSheets")
        SrcArr = .Range(.Cells(FirstDataRow, FirstClm), _
                        .Cells(.Rows.Count, FirstClm).End(xlUp).Offset(, NumClms - 1)).Value
    End With
    ReDim OutArr(1 To NumClms, 1 To UBound(SrcArr))
    
    For R = 1 To UBound(SrcArr)
        If 1 = 1 Then
            ArrIdx = ArrIdx + 1
            For C = 1 To NumClms
                OutArr(C, ArrIdx) = SrcArr(R, C)
            Next C
        End If
    Next R
    
    Debug.Print LBound(OutArr), UBound(OutArr), LBound(OutArr, 2), UBound(OutArr, 2), ArrIdx
    ReDim Preserve OutArr(LBound(OutArr) To UBound(OutArr), _
                          LBound(OutArr, 2) To ArrIdx)
    Worksheets("sourceSheets").Cells(2, "H").Resize(UBound(OutArr, 2), UBound(OutArr)) _
                              .Value = Application.Transpose(OutArr)
End Sub

This code writes the result to a range starting at H2 on the same sheet. You may wish to specify another cell elsewhere in your workbook, even another workbook.

Answer 2

Copy Rows From Another Workbook

• You cannot resize any but the last dimension of an array. Unfortunately the last dimension is columns, not rows.
• The following shows a common scenario.
• It is assumed that the code is in the Destination Workbook, while the Source Workbook is open.
• Carefully adjust the values in the Constants section.

The Code

Option Explicit

Sub resizeArray()
    
    ' Define Constants.
    
    ' Define Source Constants.
    Const srcWb As String = "AnotherWorkbook.xlsm"
    Const srcWs As String = "Sheet1"
    Const srcColumns As String = "A:C"
    Const FirstRow As Long = 1
    Const CritCol As Long = 1
    Const Criteria As Variant = "USA"
    ' Define Destination Constants
    Const dstWs As String = "Sheet1"
    Const dstFirstCell As String = "A1"
    
    ' Define Source Range.
    
    ' Define Source Workbook.
    Dim wb As Workbook
    Set wb = Workbooks(srcWb)
    ' Define Source worksheet.
    Dim ws As Worksheet
    Set ws = wb.Worksheets(srcWs)
    ' Define Source Columns Range.
    Dim cols As Range
    Set cols = ws.Columns(srcColumns)
    ' Validate Criteria column.
    If cols.Count < CritCol Then
        Exit Sub
    End If
    ' Using Criteria Column, retrieve the Last Row,
    ' the row of the last non-empty cell in the column.
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, CritCol).End(xlUp).Row
    ' Define Source Range.
    Dim rng As Range
    Set rng = ws.Columns(srcColumns).Resize(LastRow - FirstRow + 1) _
                                    .Offset(FirstRow - 1)
    
    ' Write values from Source Range to Data Array.
    
    Dim Data As Variant
    Data = rng.Value
    
    ' Loop through rows of Data Array and write the desired data to the top
    ' (beginning) of the array.
    
    ' Prepare for loop.
    Dim CurVal As Variant ' Current Value
    Dim dstRows As Long   ' Current Destination Row, Destination Rows Count
    Dim r As Long         ' Current Source Row
    Dim c As Long         ' Current Source Column, Current Destination Column
    
    ' Loop.
    For r = 1 To UBound(Data, 1)
        CurVal = Data(r, CritCol)
        If Not IsError(CurVal) Then
            If CurVal = Criteria Then
                dstRows = dstRows + 1
                For c = 1 To UBound(Data, 2)
                    Data(dstRows, c) = Data(r, c)
                Next c
            End If
        End If
    Next r
    ' Validate Destination Rows Count.
    If dstRows = 0 Then ' No Criteria was found.
        Exit Sub
    End If
    
    ' Status: Now there is undesired data at the bottom
    '         from rows 'dstrows + 1' to 'Ubound(Data, 1)'.
    '         Another array could be implemeted to retrieve the desired data,
    '         e.g. ...'Redim Another(1 To dstRows, 1 To Ubound(Data,2))'...
    '         but there is no need:

    ' Write values from Data Array to Destination Range.

    ' Define Destination Workbook.
    Set wb = ThisWorkbook ' The workbook containing this code.
    ' Define First Cell Range of Destination Range.
    Set rng = wb.Worksheets(dstWs).Range(dstFirstCell)
    ' Define Destination Range.
    Set rng = rng.Resize(dstRows, UBound(Data, 2))
    ' Write values from (the desired 'top' part of) Data Array to Destination Range.
    rng.Value = Data

End Sub

Answer 3

These solutions overcome some limitations of redimming a 2-dimensional array:

1. Simple (formula) alternative using dynamic arrays in ►Office 365 // (First post)

Write this formula to your target cell (e.g. C2, assuming target in Sheet2):

    Sheet2.Range("C2").Formula2 = "=FILTER(Sheet1!B:C,Sheet1!A:A=""USA"")"

If you want to include the repeated "USA" text, simply change to

    Sheet2.Range("C2").Formula2 = "=FILTER(Sheet1!A:C,Sheet1!A:A=""USA"")"

Once written to target, results get adapted after changes in the referred columns of the source worksheet (Sheet1).

2. Array approach for ►prior Office versions // (Edit 2020-11-06)

In order to complete above solutions I demonstrate an array approach filtering data (passed by reference) via help procedure ResizeData:

Sub Example call()
' [0] define range
  Dim lastRow As Long: lastRow = Tabelle1.Cells(Cells.Rows.Count, "A").End(xlUp).Row
  Dim rng As Range
  Set rng = Sheet1.Range("A2:C" & lastRow) ' << change to entire data range

' [1a] create 2-dim data field array (1-based)
  Dim data: data = rng.Value2
' [1b] filter data rows where items in 1st column equal "USA"
  ResizeData data                            ' or: ResizeData data, 1, "USA"

' [2] write filtered data field to any target
  Sheet2.Range("B2").Resize(UBound(data), UBound(data, 2)) = data
End Sub

Help procedure ResizeData

Using the rearranging possibilities of the Application.Index() function (and assuming to return only columns 2:3 as indicated in Evaluate() to avoid repeated "USA" fields of column 1)

Sub ResizeData(data, Optional colNo As Long = 1, Optional criteria As String = "USA")
'Purpose: filter data field array based on criteria in given column 
    data = Application.Transpose(Application.Index( _
              data, _
              getRowNums(data, colNo, criteria), _
              Evaluate("row(2:" & UBound(data, 2) & ")")))
End Sub

Function getRowNums(v, ByVal colNo As Long, criteria As String) As Variant()
' Purpose: collect row numbers meeting criteria (default ="USA" in 1st column)
' Note:    called by above procedure DelRows
  Dim tmp: ReDim tmp(0 To UBound(v) - 1)
  Dim i As Long, n As Long
  For i = 1 To UBound(v)
      If UCase$(v(i, colNo)) = criteria Then    ' check array items
         tmp(n) = i                             ' collect valid row numbers
         n = n + 1                              ' increment results counter
      End If
  Next i
  ReDim Preserve tmp(0 To n - 1)                 ' resize row numbers array
  'return function result
  getRowNums = tmp
End Function

Answer 4

Dynamic arrays can only increase the dimension last. So, we have no choice but to put the matrix in an array in a converted state.Finally, you can change the matrix again by using the Transpose function of the dynamic array whose matrix has been changed.

Sub test()
    Dim dataArray(), a()
    Dim vDB
    Dim Ws As Worksheet
    Dim i As Long, n As Long
    
    Set Ws = Sheets("sourceSheets")
    'endRow = Sheets("sourceSheets").Cells(Cells.Rows.Count, startCol).End(xlUp).Row
    'arrayIndex = 1
    vDB = Ws.UsedRange
    For i = 1 To UBound(vDB, 1)
      If vDB(i, 1) = "USA" Then
        n = n + 1
        ReDim Preserve a(1 To 3, 1 To n)  'Dynamic array can increase last dimension
        ' So, we have no choice but to put the matrix in an array in a converted state.
        a(1, n) = vDB(i, 1)
        a(2, n) = vDB(i, 2)
        a(3, n) = vDB(i, 3)
      End If
    Next
    'The Transpose function has a limit that n is 65536.
    dataArray = WorksheetFunction.Transpose(a)

End Sub

Answer 5

If you are not keeping the Data from last Array in a loop. Simply Erase it before next loop. The next loop will resize it.

I will post my vb here which i use it to combine different excel into one by using Array. [ Personally, I suggest using copy & paste which will be way faster ]

---------------KEYWORD-----------> Erase ArrayA() <----------------

Example:

Sub GetFile()



Dim ThisWB As String
Dim NewWB As String
Dim ImportLocation As String
Dim CurrentLastRow As Long
    CurrentLastRow = 1
    
Dim StartingRow As Long    
Dim RowCountNWB As Long
                        
Dim ArrayA() As String
Dim x As Long
Dim y As Long
            
Dim FileAmount As Integer
    FileAmount = Sheets("FileName").Range("B1")
  
    ThisWB = ActiveWorkbook.Name
    NewWB = Dir(ImportLocation)
    ImportLocation = Workbooks(ThisWB).Worksheets("Control").Range("B2")
     

    
'---------------------------
            
Do While NewWB <> ""
On Error Resume Next


    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    Application.CutCopyMode = False

    Workbooks.Open ImportLocation & NewWB
    Workbooks(NewWB).Activate

    RowCountNWB = _ Workbooks(NewWB).Sheets(2).Cells(3,1).CurrentRegion.Rows.Count
    

ReDim Preserve ArrayA(1 To RowCountNWB, 1 To 13)

    For x = 3 To RowCountNWB
        For y = 1 To 13
        
        ArrayA(x, y) = Workbooks(NewWB).Sheets(2).Cells(x, y)
        
        Next y
    Next x

'----------------------------------------

StartingRow = CurrentLastRow

     For x = 3 To RowCountNWB
        For y = 1 To 13
        
        Workbooks(ThisWB).Sheets("Combine").Cells(StartingRow + x - 3, y) = ArrayA(x, y)
        
        Next y
        
        CurrentLastRow = CurrentLastRow + 1
    Next x
            
    Erase ArrayA()


    'Don't Save & Close
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Workbooks(NewWB).Close
        
'----------------------------
    
        
    'Choose next excel
    NewWB = Dir()
    
Loop
        
'----------------------------


    
    Worksheets("Control").Activate
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub