How to find index of row that has all empty elements in array?

I'd like to redim the size of multidimensional array that has many empty elements,

For one dimensional array I came up with this short code to find the index of first empty element.

arr = Array(4, 6, 7, "fjf", Empty, Empty, Empty)

i = 1
While arr(i) <> Empty
    i = i + 1
Wend

But is there a more direct way for a 2 dimensional array like below, to identify index of "row" with all empty elements? in this case should be 4.

Dim myArray(1 To 5, 1 To 7) As Variant
    myArray(1, 1) = 1
    myArray(1, 2) = 2
    myArray(1, 3) = 3
    myArray(1, 4) = 4
    myArray(1, 5) = 5
    myArray(2, 1) = 6
    myArray(2, 2) = 7
    myArray(2, 3) = 8
    myArray(2, 4) = 9
    myArray(2, 5) = 10
    myArray(3, 1) = 6
    myArray(3, 2) = 7
    myArray(3, 3) = 8
    myArray(3, 4) = 9
    myArray(3, 5) = 10

Get Elements Before First Empty Row

The Function

<!-- language: lang-vb -->

Function GetBeforeEmptyRow(ByVal Data As Variant) As Variant

    Dim LB1 As Long: LB1 = LBound(Data, 1)
    Dim UB1 As Long: UB1 = UBound(Data, 1)
    Dim LB2 As Long: LB2 = LBound(Data, 2)
    Dim UB2 As Long: UB2 = UBound(Data, 2)
    
    Dim r As Long, c As Long
    
    For r = LB1 To UB1
        For c = LB2 To UB2
            If Not IsEmpty(Data(r, c)) Then ' the row is not empty
                Exit For
            End If
        Next c
        If c > UB2 Then ' the row is empty
            Exit For
        End If
    Next r
    
    UB1 = r - 1
    
    Dim dData ' initially 'Empty' 
    
    If UB1 >= LB1 Then
        ReDim dData(LB1 To UB1, LB2 To UB2)
        For r = LB1 To UB1
            For c = LB2 To UB2
                dData(r, c) = Data(r, c)
            Next c
        Next r
    'Else ' the 1st row is empty; do nothing i.e. let the result be 'Empty' 
    End If

    GetBeforeEmptyRow = dData

End Function

The Test

<!-- language: lang-vb -->

Sub Test()

    Dim myArray(1 To 5, 1 To 7) As Variant
    myArray(1, 1) = 1
    myArray(1, 2) = 2
    myArray(1, 3) = 3
    myArray(1, 4) = 4
    myArray(1, 5) = 5
    myArray(2, 1) = 6
    myArray(2, 2) = 7
    myArray(2, 3) = 8
    myArray(2, 4) = 9
    myArray(2, 5) = 10
    myArray(3, 1) = 6
    myArray(3, 2) = 7
    myArray(3, 3) = 8
    myArray(3, 4) = 9
    myArray(3, 5) = 10
    
    Dim Data(): Data = GetBeforeEmptyRow(myArray)
    
    Debug.Print "Initial Limits [" & LBound(myArray, 1) & "," _
        & UBound(myArray, 1) & "][" & LBound(myArray, 2) & "," _
        & UBound(myArray, 2) & "]"
    
    If IsEmpty(Data) Then
        Debug.Print "The first row was empty."
    Else
        Debug.Print "Result Limits  [" & LBound(Data, 1) & "," _
            & UBound(Data, 1) & "][" & LBound(Data, 2) & "," _
            & UBound(Data, 2) & "]"
    End If

End Sub

The Result

Initial Limits [1,5][1,7]
Result Limits  [1,3][1,7]

The 1D Method (Redim Preserve)

<!-- language: lang-vb -->

Sub RemoveAfterEmpty(ByRef Arr As Variant)
    
    Dim LB As Long: LB = LBound(Arr)
    Dim UB As Long: UB = UBound(Arr)
    
    Dim n As Long
    
    For n = LB To UB
        If IsEmpty(Arr(n)) Then
            Exit For
        End If
    Next n
    
    n = n - 1
    
    If n >= LB Then ' the 1st element is not empty
        If n < UB Then
            ReDim Preserve Arr(LB To n)
        'Else ' no empty elements; do nothing
        End If
    Else ' the 1st element is empty
        Arr = Array()
    End If

End Sub

The 1D Test

<!-- language: lang-vb -->

Sub Test1D()
    
    Dim Arr(): Arr = Array(4, 6, 7, "fjf", Empty, Empty, Empty)
    
    Debug.Print "Initial [" & LBound(Arr) & "," & UBound(Arr) & "]"
    Debug.Print Join(Arr, ", ")
    
    RemoveAfterEmpty Arr
    
    If UBound(Arr) < LBound(Arr) Then
        Debug.Print "The first element was empty."
    Else
        Debug.Print "Result  [" & LBound(Arr) & "," & UBound(Arr) & "]"
        Debug.Print Join(Arr, ", ")
    End If

End Sub

The 1D Result

Initial [0,6]
4, 6, 7, fjf, , , 
Result  [0,3]
4, 6, 7, fjf