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?