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

Answer 1

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