Re: Matching keywords with Product Description
Sorry bout that, Here is the code modified for single word lookup.
Keep in mind, that partial match's are found which I think is what you wanted. So only typing in a few letters for a word for a match will find more results
Sub Elfabb()
Dim vData() As Variant, vFind() As Variant, vPaste() As Variant
Dim lData As Long, lFind As Long
Dim sTest As String
With Worksheets("WksInput")
vData = .Range("B3").Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 2, 3).Value
End With
With Worksheets("WksOutput")
lFind = .Cells(Rows.Count, 6).End(xlUp).Row - 2
If lFind > 1 Then
vFind = .Range("F3").Resize(.Cells(Rows.Count, 6).End(xlUp).Row - 2, 1).Value
Else
ReDim vFind(1 To 1, 1 To 1)
vFind(1, 1) = .Range("F3").Value
End If
lFind = .Cells(Rows.Count, 2).End(xlUp).Row
If lFind > 2 Then .Range("B3:D" & lFind).Delete shift:=xlUp
End With
ReDim vPaste(1 To 3, 1 To 1)
For lData = LBound(vData, 1) To UBound(vData, 1)
sTest = UCase(vData(lData, 3))
For lFind = LBound(vFind, 1) To UBound(vFind, 1)
If InStr(1, sTest, UCase(vFind(lFind, 1)), vbTextCompare) > 0 Then
vPaste(1, UBound(vPaste, 2)) = vData(lData, 2) 'Product Code
vPaste(2, UBound(vPaste, 2)) = vData(lData, 3) 'Product Description
vPaste(3, UBound(vPaste, 2)) = vData(lData, 1) 'Supplier
ReDim Preserve vPaste(1 To 3, 1 To UBound(vPaste, 2) + 1)
End If
Next lFind
Next lData
With Worksheets("WksOutput")
If UBound(vPaste, 2) > 1 Then
.Range("B3").Resize(UBound(vPaste, 2), 3) = Application.WorksheetFunction.Transpose(vPaste)
lFind = .Cells(Rows.Count, 3).End(xlUp).Row
If lFind > 3 Then .Range("B3").Resize(lFind, 3).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
End If
End With
End Sub
Display More