Sub CheckKeywordAndAttributes()
Dim arrKey(), arrAtt(), arrOut(), strKey As String, s As String, isFound As Boolean
Dim i As Long, j As Long, k As Long, p As Long
With Sheets("data")
arrKey = .Range("B2").CurrentRegion.Value
arrAtt = .Range("D2").CurrentRegion.Value
ReDim arrOut(1 To UBound(arrAtt, 1), 1 To UBound(arrAtt, 2))
End With
With Sheets("input")
s = " " & Replace$(Replace$(.Range("B3").Value, ".", " "), ",", " ") & " "
isFound = False
For i = 2 To UBound(arrKey, 1)
If InStr(1, s, " " & arrKey(i, 1) & " ") Then
isFound = True
strKey = arrKey(i, 1)
Exit For
End If
Next i
If Not isFound Then MsgBox "nothing found": Exit Sub
p = 0
For i = 2 To UBound(arrAtt, 1)
If arrAtt(i, 1) = strKey Then
For j = 2 To UBound(arrAtt, 2)
If Len(arrAtt(i, j)) * InStr(1, s, " " & arrAtt(i, j) & " ") Then
p = p + 1
For k = 1 To UBound(arrAtt, 2)
arrOut(p, k) = arrAtt(i, k)
Next k
GoTo there
End If
Next j
there:
End If
Next i
With .Range("B31")
.CurrentRegion.ClearContents
If p > 0 Then
.Resize(p, UBound(arrOut, 2)).Value = arrOut
End If
End With
End With
End Sub
Sub CheckKeywordOnly()
Dim arrKey(), arrAtt(), arrOut(), strKey As String, s As String, isFound As Boolean
Dim i As Long, j As Long, p As Long
With Sheets("data")
arrKey = .Range("B2").CurrentRegion.Value
arrAtt = .Range("D2").CurrentRegion.Value
ReDim arrOut(1 To UBound(arrAtt, 1), 1 To UBound(arrAtt, 2))
End With
With Sheets("input")
s = " " & Replace$(Replace$(.Range("B3").Value, ".", " "), ",", " ") & " "
isFound = False
For i = 2 To UBound(arrKey, 1)
If InStr(1, s, " " & arrKey(i, 1) & " ") Then
isFound = True
strKey = arrKey(i, 1)
Exit For
End If
Next i
If Not isFound Then MsgBox "nothing found": Exit Sub
p = 0
For i = 2 To UBound(arrAtt, 1)
If arrAtt(i, 1) = strKey Then
p = p + 1
For j = 1 To UBound(arrAtt, 2)
arrOut(p, j) = arrAtt(i, j)
Next j
End If
Next i
With .Range("B31")
.CurrentRegion.ClearContents
If p > 0 Then
.Resize(p, UBound(arrOut, 2)).Value = arrOut
End If
End With
End With
End Sub
Bookmarks