VBA Copy row from one 2D array and add it to another 2D array

Question

I have a large database (~7000 rows x 25 columns) that i have assigned to an array. Based on user inputs, I am trying to search the database to find items that match the input and copy the entire row to a new array to create a new database to filter with the next question. The arrays are DBRange and DBT and are defined as public variants. I've tried copying the data from DBRange to a new sheet, but that is incredibly slow and I'm trying to speed things up with keeping things within arrays if possible.

DBRange = wsd.Range("A1").CurrentRegion 'Sets DBRange to the entirety of the Database


Cervical = 0

If CervicalStartOB.Value = True Then
Cervical = 1
SpineSection.Hide

For i = LBound(DBRange, 1) To UBound(DBRange, 1) 'starts for loop starting with the 1st row in the array to the last row
    If DBRange(i, 13) = "X" Then  'determines if the value in row i column 13 has an X
    ReDim Preserve DBT(count, UBound(DBRange, 2))
    DBT(count, UBound(DBRange, 2)) = Application.WorksheetFunction.Index(DBRange, i, 0)
    count = count + 1 
    
    End If
  Next i

`ReDim Preserve` is expensive, and should be avoided, especially in a loop. Also, I somewhat hate to mention this, but it really sounds like you're (ab)using Excel as a database. — BigBen, Feb 11 '22 at 17:17
If you have a sheet of data to search, you can use `Range.Find` and `Range.FindNext` to quickly create a collection of all cells containing your search term. Then you can count the number of cells in that collection and create an array of the correct size without guessing. This avoids `ReDim Preserve`. Other than `Range.Find` you could take the entire table column (just one column) into an array and loop though it item by item. — Toddleson, Feb 11 '22 at 18:27
What does *to filter with the next question* mean? Please do clarify because you may want to do all of it in one go. — VBasic2008, Feb 11 '22 at 18:49
The spreadsheet goes through a series of "this or that" questions to run the user through a essentially a tree diagram to give the final recommendation. It may be easier to do it all in one go, but i thought it might be quicker to narrow the database as you go vs searching the full 7000 rows for items that match 4+ parameters — csmith711, Feb 11 '22 at 19:13

VBasic2008 · Answer 1 · 2022-02-11T21:10:49.117

Get Range Criteria Rows

Option Explicit


Sub GetRangeCriteriaRowsTESTKeepHeaders()
    
    Const sCriteriaString As String = "X"
    Const sCol As Long = 13
    Const sfRow As Long = 2 ' First Data Row
    
    Dim wsd As Worksheet: Set wsd = ActiveSheet
    
    ' Reference the source range
    Dim srg As Range: Set srg = wsd.Range("A1").CurrentRegion
    
    ' Write the criteria rows to an array.
    ' If you want to keep headers, use the first row ('sfrow')
    ' as the parameter of the 'FirstRow' argument of the function.
    Dim DBT As Variant
    DBT = GetRangeCriteriaRows(srg, sCriteriaString, sCol, sfRow)
    If IsEmpty(DBT) Then Exit Sub

End Sub


Sub GetRangeCriteriaRowsTESTOnlyData()
    
    Const sCriteriaString As String = "X"
    Const sCol As Long = 13
    Const sfRow As Long = 2 ' First Data Row
    
    Dim wsd As Worksheet: Set wsd = ActiveSheet
    
    ' Reference the source range.
    Dim srg As Range: Set srg = wsd.Range("A1").CurrentRegion
    
    ' Reference the data range (no headers).
    Dim shrCount As Long: shrCount = sfRow - 1
    Dim sdrg As Range
    Set sdrg = srg.Resize(srg.Rows.Count - shrCount).Offset(shrCount)
    
    ' Write the criteria rows to an array.
    ' If the range has no headers, don't use the 'FirstRow' argument
    ' of the function.
    Dim DBT As Variant: DBT = GetRangeCriteriaRows(sdrg, sCriteriaString, sCol)
    If IsEmpty(DBT) Then Exit Sub

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of the rows of a range ('SourceRange'),
'               that meet a string criterion ('CriteriaString') in a column
'               ('CriteriaColumnIndex'), in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRangeCriteriaRows( _
    ByVal SourceRange As Range, _
    ByVal CriteriaString As String, _
    Optional ByVal CriteriaColumnIndex As Long = 1, _
    Optional ByVal FirstRow As Long = 1) _
As Variant
    Const ProcName As String = "GetRangeCriteriaRows"
    On Error GoTo ClearError

    ' Count the source rows and the source/destination columns.
    Dim srCount As Long: srCount = SourceRange.Rows.Count
    Dim cCount As Long: cCount = SourceRange.Columns.Count
    ' Count the source header rows.
    Dim shrCount As Long: shrCount = FirstRow - 1
    
    ' Define the source data range according to the first row.
    Dim sdrg As Range
    Set sdrg = SourceRange.Resize(srCount - shrCount).Offset(shrCount)
    
    ' Write the source range values to the source array.
    Dim sData As Variant: sData = SourceRange.Value
    
    ' Count the criteria rows in the source data criteria column range.
    Dim sdcrg As Range: Set sdcrg = sdrg.Columns(CriteriaColumnIndex)
    Dim drCount As Long
    drCount = Application.CountIf(sdcrg, CriteriaString) + shrCount
    
    ' Define the destination array.
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim sr As Long ' Current Source Row
    Dim c As Long ' Current Source/Destination Column
    Dim dr As Long ' Current Destination Row
    
    ' Write the header rows from the source array to the destination array.
    If FirstRow > 1 Then
        For sr = 1 To shrCount
            dr = dr + 1
            For c = 1 To cCount
                dData(dr, c) = sData(sr, c)
            Next c
        Next sr
    End If
    
    ' Write the criteria rows from the source array to the destination array.
    For sr = FirstRow To srCount
        If StrComp(CStr(sData(sr, CriteriaColumnIndex)), CriteriaString, _
                vbTextCompare) = 0 Then
            dr = dr + 1
            For c = 1 To cCount
                dData(dr, c) = sData(sr, c)
            Next c
        End If
    Next sr
    
    GetRangeCriteriaRows = dData
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

VBA Copy row from one 2D array and add it to another 2D array

1 Answers1

Get Range Criteria Rows

Linked