5
\$\begingroup\$

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 20 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
\$\endgroup\$
  • \$\begingroup\$ Welcome to Code Review, glad you chose to post it here! I edited the title to say what the code does (which is the norm here). I hope you get some great reviews! \$\endgroup\$ – Phrancis Apr 13 '15 at 19:12
  • 1
    \$\begingroup\$ To be clear about our scope, we can help you clean up what you've done, but implementing new features is outside of the scope of this site. \$\endgroup\$ – RubberDuck Apr 13 '15 at 19:20
6
\$\begingroup\$
  • Instead of hard coding x number of searches, add a loop (I used a While...Wend) that repeats until the user enters a blank search term. This will allow them to search for as few or as many words as they need to on this run.
  • Instead of looping through all the cells of the worksheet, using the .Find() method will be much, much faster. There are a couple of caveats
    • .Find() uses the current Find settings exactly as they are in the find dialog box, so you'll want to set as many of the parameters as are important to you. I've set a minimum in the code sample - you may need more
    • .Find() will continue looping through your workbook with no warning that it's returned to the top, so you need to store off the address of your first found item & compare it each time through.

Something like this:

'Application.ScreenUpdating = False
Dim lastLine As Long
Dim toCopy As Boolean
Dim cell As Range

Dim findWhat As String
Dim i As Long
Dim j As Long
Dim rng as Range
Dim Address as string

s = 2
findWhat = CStr(InputBox("What word would you like to search for today?"))
While Len(FindWhat)> 0  'loop until they enter a blank search string
  j = 1
  rng = ActiveSheet.Find(What:=findWhat, LookIn:=xlValues)
  if not rng is Nothing and rng.address <> address then 'if we found something & it's not the first cell we found
    if len(address) = 0 then 'if this is our first find
      address = rng.address  'store the cell address so we don't loop forever
    end if
    rng.copy destination:=Sheets(s).Rows(j)
    j = j+1
    rng = ActiveSheet.Find(What:=findWhat, LookIn:=xlValues)
  end if

  s = s + 1

  MsgBox j - 1 & " results were copied"
  findWhat = CStr(InputBox("What other word would you like to search for today?"))
Wend
\$\endgroup\$
  • 1
    \$\begingroup\$ Welcome to CodeReview, FreeMan. Here, we like a little bit more context in our reviews. This could be a really great answer, but as it stands is little more than a code dump. Add some more context to your answer to illustrate what your code does and why you choose to do it in that way. \$\endgroup\$ – Legato Apr 13 '15 at 19:27
  • \$\begingroup\$ The only bug I see is what happens when the user performs more searches than there are sheets. (I'm assuming that previously there were enough sheets) \$\endgroup\$ – Snowbody Apr 14 '15 at 2:54
  • \$\begingroup\$ It's pretty simple, @Snowbody, the code crashes and throws an error! :) Yeah, there should be some logic in there to add in a new sheet if one doesn't exist. \$\endgroup\$ – FreeMan Apr 16 '15 at 14:47
4
\$\begingroup\$

@FreeMan did a great job at loopifying your Copy+Paste code; I just have a few more [important] points to add:

Option Compare Text

Great, so you know about module options. One that you should always systematically add to every VBA code module you ever write code in, is Option Explicit: that option will prevent the code from running (compiling actually) if you're using a variable that you haven't declared anywhere.

As it turns out, variable s isn't declared, so Option Explicit would break your code until you add a declaration for it.

The easiest way to ensure Option Explicit is always on, is to have it enforced by the VBA Editor itself - check the "require variable declaration" box in the Tools/Options menu:

"require variable declaration" checkbox in the "Editor" options

Another way is to install the Rubberduck VBE add-in (disclaimer: I wrote it with @RubberDuck), and to run code inspections:

Rubberduck code inspections

As you can see the static code analysis tool is picking up another issue in your code: the Macro2 procedure is implicitly public. This would fix it:

Public Sub Macro2()

What's the difference? Well, did you know that unless a Private access modifier is specified, all procedures (and functions) in a code module are public by default? Not a big deal really, but readability-wise, being explicit about these things helps tremendously - especially if you're coming from [pretty much any] another language, where members are all private unless specified otherwise.


Meaningful Names

One of the hardest thing in programming, you'll find, is naming things (well, that and cache invalidation, apparently). A procedure called Macro2 only means, to me (to future you as well), that there's possibly another procedure somewhere called Macro1... maybe.

A good way to make it easier to name things, is to write small procedures that do as little as possible - when procedures do only one thing, naming them after what they do becomes pretty simple. Procedures do something, so their names should start with a verb.

Single-letter identifiers are also meaningless. s surely means something... but nobody knows what until they scanned all its usages and inferred its meaning - a name like destinationSheetIndex would bring sunshine to the life of whoever is maintaining that code.


DANGER!

This line is dangerous:

Application.ScreenUpdating = False

It has the power to make your user believe Excel has frozen when, in reality, it's just idle and happily waiting for SceenUpdating to be turned back on.

You should only use it in procedures where you're properly handling any possible runtime error that might happen - by Murphy's Law there will always be a way for something that can go wrong, to go wrong.

Here's a procedure template I use all the time:

Private Sub DoSomething()
    On Error GoTo CleanFail

    'method body goes here

CleanExit:
    'cleanup code goes here
    Exit Sub

CleanFail:
    'error-handling code goes here
    Resume CleanExit
End Sub

So, if the method body needs to turn ScreenUpdating off, you can avoid confusing users by simply specifying Application.ScreenUpdating = True under the CleanExit subroutine, so that whatever happens, screen updating is restored before the procedure exits. I wouldn't rely on Excel to automatically clean up for me.

\$\endgroup\$
  • \$\begingroup\$ Good call with the screen updating. VBA is so cumbersome without Try...Finally blocks. \$\endgroup\$ – Rossco Apr 14 '15 at 1:35
  • 1
    \$\begingroup\$ I like the variation. "There are two hard things in C.S., cache invalidation, naming things, and off by one errors." \$\endgroup\$ – RubberDuck Apr 14 '15 at 2:14
  • \$\begingroup\$ I did leave Application.screenUpdating=False commented out... :) \$\endgroup\$ – FreeMan Apr 14 '15 at 2:31

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.