Filter 2d array returns empty result

[YasserKhalil]

Hello everyone

I have a UDF that filters 2d array and the udf works fine if there are multiple rows that match the criterias. Here's my main code

Code: Select all

Sub MyTest()
    Dim a, b, v, rng As Range, lr As Long
    Set rng = ThisWorkbook.Worksheets("Sheet1").Range("L7:O10")
    v = ConvertRangeTo1DArray(rng)
    With shCS
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A4:FE" & lr).value
    End With
    b = Filter2DArray(a, v)
    With ThisWorkbook.Worksheets("Sheet2")
        .Range("A1").Resize(UBound(b, 1), UBound(b, 2)).value = b
    End With
End Sub

At this point ` b = Filter2DArray(a, v)` I got a 2d array but all elements are empty (just when the criteria doesn't matched and that is fine for me)
but I don't need to execute these line if the array is empty

Code: Select all

    With ThisWorkbook.Worksheets("Sheet2")
        .Range("A1").Resize(UBound(b, 1), UBound(b, 2)).value = b
    End With

[YasserKhalil]

I could solve the point of empty elements of the array. here's my full code

Code: Select all

Sub MyTest()
    Dim a, b, v, rng As Range, lr As Long
    Set rng = ThisWorkbook.Worksheets("Sheet1").Range("L7:O10")
    v = ConvertRangeTo1DArray(rng)
    With shCS
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A4:FE" & lr).value
    End With
    b = Filter2DArray(a, v)
    If UBound(b, 1) = 0 Then
    Debug.Print "Empty Array"
    Else
        With ThisWorkbook.Worksheets("Sheet2")
            .Range("A1").Resize(UBound(b, 1), UBound(b, 2)).value = b
        End With
    End If
End Sub

Function ConvertRangeTo1DArray(ByVal rng As Range)
    Dim aCols, aCrit, s As String, c As Long, r As Long
    aCols = Application.Transpose(Application.Transpose(rng.Rows(1).value))
    ReDim aCrit(1 To rng.Columns.Count)
    For c = 1 To rng.Columns.Count
        s = vbNullString
        For r = 2 To rng.Rows.Count
            If rng.Cells(r, c).value <> Empty Then
                s = s & IIf(s = Empty, Empty, "|") & rng.Cells(r, c).value
            End If
        Next r
        aCrit(c) = s
    Next c
    ConvertRangeTo1DArray = Array(aCols, aCrit)
End Function

Function Filter2DArray(ByVal a, ByVal v)
    Dim b, f As Boolean, i As Long, j As Long, k As Long, ii As Long, cnt As Long
    ReDim aCols(1 To UBound(v(0)))
    ReDim aCrit(1 To UBound(v(1)))
    For ii = LBound(v(i)) To UBound(v(i))
        aCols(ii) = v(0)(ii)
        aCrit(ii) = v(1)(ii)
    Next ii
    ReDim b(1 To UBound(a, 1), LBound(a, 2) To UBound(a, 2))
    For i = LBound(a, 1) To UBound(a, 1)
        f = True
        For j = LBound(aCols) To UBound(aCols)
            k = aCols(j)
            If InStr(1, aCrit(j), a(i, k)) > 0 Then
            Else
                f = False: Exit For
            End If
        Next j
        If f Then
            cnt = cnt + 1
            For j = LBound(a, 2) To UBound(a, 2)
                b(cnt, j) = a(i, j)
            Next j
        End If
    Next i
    If cnt > 0 Then
        b = Application.Transpose(b)
        ReDim Preserve b(1 To UBound(b, 1), 1 To cnt)
        b = Application.Transpose(b)
    Else
         ReDim b(0 To 0, 0 To 0)
    End If
    Filter2DArray = b
End Function

Just one problem with the udf when I got only one match (I mean when cnt equals to 1). How can I fix that?

[YasserKhalil]

I could solve it by modifying this part

Code: Select all

    If cnt > 1 Then
        b = Application.Transpose(b)
        ReDim Preserve b(1 To UBound(b, 1), 1 To cnt)
        b = Application.Transpose(b)
    ElseIf cnt = 1 Then
        b = Application.Index(b, 1, 0)
        ReDim c(1 To 1, 1 To UBound(b))
        For i = LBound(b) To UBound(b)
            c(1, i) = b(i)
        Next i
        b = c
    Else
        ReDim b(0 To 0, 0 To 0)
    End If

But I welcome any better ideas.