Remove extra blank elements in an array VBA

Question

I have created an array for a data dump over 35k rows long. I want to only add items in the array that contain 16250 (about 1100 items). So far I've created an array, but it goes all the way to 35k. How do I shorten the limit of the array to stop once the last cell with 16250 is added?

Dim A(), i as long, j as integer
nr = WorksheetFunction.CountA(Range(Cells(2, 1), Cells(2, 1).End(xlDown))) + 1
nc = Range(Cells(2, 1), Cells(2, 1).End(xlToRight)).Columns.Count

'CBK Array A()
ReDim A(3 To nr, 1 To nc)

For i = 3 To nr
    For j = 1 To nc
            A(i, j) = Cells(i, j)
        End If
    Next j
Next i

'create sheet specific array
Dim shArr()
ReDim shArr(3 To nr, 1 To nc)
For i = 3 To nr
    For j = 1 To nc
        If Left(A(i, 4), 5) = "16250" Then
            shArr(i, j) = A(i, j)
        End If
    Next j
Next i

So array A goes to 35k, but I want ShArr to only go to around 1100.

I have tried ubound(a), but it included the empty cells even thought I heard from Chat GTP that it shouldn't.

Answer 1

Something like the following should work (semi-tested).

You can read the range into the array A with one line. No need for a loop.

Then get a count of elements starting with "16250" from the 4th column of A.

Then ReDim ShArr based on that count.

Then load the relevant data into ShArr.

Dim A() As Variant, lastRow As Long, lastCol As Long

lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(2, Columns.Count).End(xlToLeft).Column

A = Range("A2", Cells(lastRow, lastCol)).Value

Dim i As Long, counter As Long

For i = Lbound(A, 1) to Ubound(A, 1)
    If Left(A(i, 4), 5) = "16250" Then
        counter = counter + 1
    End If
Next

Dim shArr() As Variant
ReDim shArr(1 to counter, 1 to lastCol)

Dim idx As Long, j As Long
For i = Lbound(A, 1) To Ubound(A, 1)
    If Left(A(i, 4), 5) = "16250" Then
        idx = idx + 1
    
        For j = Lbound(A, 2) To Ubound(A, 2)
            shArr(idx, j) = A(i, j)            
        Next
    End If
Next

If the elements beginning with 16250 are alphanumeric, then you can use WorksheetFunction.CountIfs with a wildcard * to get the count, and skip the first loop above.

Answer 2

Match Rows

Sub MatchRows()
    
    ' Define constants.
    
    Const SRC_FIRST_DATA_CELL As String = "A3"
    Const BEGINS_WITH As String = "16250"
    Const CRITERIA_COLUMN As Long = 4
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Return the values from the source range in an array.
    
    Dim sfCell As Range: Set sfCell = ws.Range(SRC_FIRST_DATA_CELL)
    
    Dim srg As Range:
    
    With sfCell.CurrentRegion
        Set srg = sfCell.Resize(.Row + .Rows.Count - sfCell.Row, _
            .Column + .Columns.Count - sfCell.Column)
    End With

    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    
    If cCount < CRITERIA_COLUMN Then
        MsgBox "There is not enough columns.", vbCritical
        Exit Sub
    End If
    
    Dim sData(): sData = srg.Value ' assumes 'srCount * cCount > 1'.
    
    ' Return the row numbers of matches in a collection
    
    Dim coll As Collection, sr As Long, sStr As String, IsFirstFound As Boolean
    
    For sr = 1 To srCount
        sStr = CStr(sData(sr, CRITERIA_COLUMN))
        If InStr(1, sStr, BEGINS_WITH, vbTextCompare) = 1 Then
            If Not IsFirstFound Then
                Set coll = New Collection
                IsFirstFound = True
            End If
            coll.Add sr
        End If
    Next sr
    
    If coll Is Nothing Then
        MsgBox "No matches found.", vbExclamation
        Exit Sub
    End If
    
    ' Return the matching rows in another array.
    
    Dim drCount As Long: drCount = coll.Count
    Dim dData(): ReDim dData(1 To drCount, 1 To cCount)
    
    Dim dr As Long, c As Long
    
    For dr = 1 To drCount
        sr = coll(dr)
        For c = 1 To cCount
            dData(dr, c) = sData(sr, c)
        Next c
    Next dr
    
    ' Continue using 'dData', e.g. copy next to the source data (see screenshot):
    
'    Dim dcell As Range: Set dcell = sfCell.Offset(, cCount + 1)
'    Dim drg As Range: Set drg = dcell.Resize(drCount, cCount)

'    drg.Value = dData
'    drg.Resize(ws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear

'    MsgBox "Matching rows copied.", vbInformation
    
End Sub