FindInArray.Bas

Option Explicit
Function FindInArray(fStr As Variant, sArr As Variant) As Variant
On Error GoTo thoat
If IsObject(fStr) Then
   If fStr.Columns.Count = 1 And fStr.Rows.Count = 1 Then
      fStr = fStr.Value2
   Else
      Exit Function
   End If
End If
fStr = LCase(CStr(fStr))
If IsObject(sArr) Then
   If sArr.Count > 1 Then sArr = sArr.Value2
End If
If IsEmpty(sArr) Then Exit Function
If fStr = vbNullString Then
   FindInArray = sArr
   Exit Function
Else
   Dim DK As Boolean, I As Long, J As Long, K As Byte, TMP() As Long, TmpArr
   ReDim TmpArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2)) As Byte
   ReDim TMP(1 To UBound(sArr, 1)) As Long
   TmpArr = sArr
   For I = LBound(TmpArr, 1) To UBound(TmpArr, 1)
       For K = 1 To UBound(TmpArr, 2)
           DK = (LCase(CStr(TmpArr(I, K))) Like "*" & fStr & "*")
           If DK Then
              J = J + 1
              TMP(J) = I
              Exit For
           End If
       Next
   Next
   If J > 0 Then
      Dim Arr As Variant, ID As Long
      ReDim Arr(1 To J, 1 To UBound(TmpArr, 2))
      For I = 1 To J
          ID = TMP(I)
          For K = 1 To UBound(TmpArr, 2)
              Arr(I, K) = TmpArr(ID, K)
          Next
      Next
      FindInArray = Arr
      Exit Function
   End If
End If
thoat:
Exit Function
End Function