InputBox for a string of 2 to 3 keywords, separated with commas.

[u473]

Is it the most practical way to go at it, and if so, how will I
retrieve each keyword ?
Second Step :
I then want to search column A for the occurence of a minimum of 2 of
those keywords,
and if found then display the entire row on Sheet2.

1. Column A Test Data Column B remarks.....
2. Applle, Cherry, Pear
3. Orange, Peach, Lemon
4. Lemon, Mango, Cherry
5. Cherry,Kiwi, Lemon

Keyword string from InpuBox : Lemon, Pear, Cherry
Row 4 and 5 should be returned.

Pseudo Code
Enter keywords string
Extract Keywords and number of (2 or 3)
Retrieve LastRow of Data
Relevance = 0
For Row 2 to Last Row in Column A
If First Keyword is found then Relevance = 1
If Second Keyword is found then Relevance = Relevance + 1
If number of Keywords is 3 and if Third Keyword is found then
Relevance = Relevance + 1
If Relevance > 1 then write entire Record to Sheet2 with
Relevance value in Column D
Relevance = 0
Next Row

Help appreciated,
J.P.

 

[Dave Peterson]

You say copy the entire record (row?) to the sheet2, but then you say to put the
counter in column D.

I'm gonna guess that the entire record is just the stuff in columns A:C.

If that's ok:

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim RptWks As Worksheet

Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long

Dim myWords As String
Dim ArrayOfWords As Variant
Dim wCtr As Long
Dim HowManyWords As Long

Dim MatchCtr As Long
Dim MatchLimit As Long
Dim StrToCompare As String

Dim DestCell As Range

Set wks = Worksheets("Sheet1")
Set RptWks = Worksheets("Sheet2")

MatchLimit = 2

myWords = InputBox(Prompt:="Enter 2 or 3 keywords separated by commas")

'remove all spaces!
myWords = Replace(myWords, " ", "")
If myWords = "" Then
Exit Sub
End If

ArrayOfWords = Split(myWords, ",")

HowManyWords = UBound(ArrayOfWords) - LBound(ArrayOfWords) + 1

If HowManyWords < 2 _
Or HowManyWords > 3 Then
MsgBox "only 2 or 3 words!"
Exit Sub
End If

With wks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = FirstRow To LastRow
StrToCompare = Replace(.Cells(iRow, "A").Value, " ", "")
StrToCompare = "," & StrToCompare & ","

MatchCtr = 0
For wCtr = LBound(ArrayOfWords) To UBound(ArrayOfWords)
If InStr(1, StrToCompare, "," & ArrayOfWords(wCtr) & ",", _
vbTextCompare) > 0 Then
'found a match
MatchCtr = MatchCtr + 1
End If
Next wCtr

If MatchCtr >= MatchLimit Then
With RptWks
Set DestCell _
= .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
'copy this row (columns A:C)
.Cells(iRow, "A").Resize(1, 3).Copy _
Destination:=DestCell
'include the counter
DestCell.Offset(0, 3).Value = MatchCtr
End If
Next iRow
End With

End Sub

 

[u473]

Thank you, thank you.
Meanwhile, I while searching on "InputBox Mutiple Values" and I found
a close answer from you on June 23, 2003.
Thank you again.
Have a good day,
J.P.