Look for keywords and copy to another sheet - excel

Question

I currently have a working code that does exactly what I want it to do, loops through a particular part of an excel document looking for certain keywords, then pasting those keywords into a separate sheet in the excel spreadsheet. It is just very long and doesn't allow for any more than 10 repetitions. I was wondering if anyone had advice on making this code loop until the user selects vbNo when asked if they have any more keywords?
Option Compare Text
Sub Macro2()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+h
'
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
s = 2
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(s).Rows(j)
j = j + 1
End If
toCopy = False
Next
s = s + 1

Answer 1

What you want to do is make a loop that will continue until the user chooses to stop by hitting cancel in your input box. To start the loop, set the loop check variable, "continue" to be equal to the result of clicking 'yes' on the box that asks if the user wants to continue.
Then, after executing the code, ask the user if they wish to add another word. If not, the loop will end. If so, the loop will continue and do another word.
Here's a start....
Dim Continue As Long
Dim findWhat As String
Dim LastLine As Long
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
Dim newsheet As Worksheet
s = 2
Continue = vbYes 'initialize loop variable
Do While Continue = vbYes 'keep getting more use input until they state they do not want to continue
findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
For Each cell In Range("BU1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Set newsheet = activeworkbook.sheets.add
newsheet.name = findWhat
Rows(i).Copy Destination:=newsheet.Rows(j)
j = j + 1
End If
Set newsheet = Nothing
toCopy = False
Next i
s = s + 1
'find out if user wishes to continue.
Continue = MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion)
Loop