VB Macro almost completed & works, just need help with last step please & Thanks!

[BoaterDave]

Hi,
I could really use some help please and thanks...
I am not a VB Macro programmer at all.

However, I have pieced together code from this forum to do almost exactly what I want it to do, it works, with one exception, it stops after the first instance found. Let me explain further.

<style></style>My goal is to have the macro read the entire worksheet, and test column "G" for a word string within the cell that could be located anywhere in the string of text in that cell.

Once it finds the word string I want to find in that cell for that row, (for this example "cups" other examples would be: "cups" or "dinner Plates", etc). then have the macro extract that entire row where it found the word "cups" into a new tab within the worksheet that becomes "Extracted Data".

GOOD NEWS:
The macro I have pieced together in the attached worksheet does exactly this for multiple worksheets. I don't need or care about the multiple worksheets, just the one worksheet I am working with. However this macro does work for my needs, but searches through the first worksheet, and extracts ONLY the 1st instance of the data with the word "cups" in the string in that cell. And it does copy the entire row to the Extracted Data tab just like I want it too. The problem is...


Bad News:
I need it to continue on to search the rest of the rows for the same string in column G and extract the entire row for each instance it finds in the entire worksheet until it runs out of rows to find the word string "cup", and extract each instance to the Extracted Data Tab.

It works perfect now for the 1st instance only, BUT, it stops after the first instance found and writes it to the Extracted Data tab. I don't know what to do to have it continue to the next row beyond the first instance found to read any remaining rows of data that have the word "cups" in the word string in column G. All I need is a loop or counter somehow to have it continue reading the full spreadsheet and do exactly what it does for the first instance, and that is write the entire row to the extracted data tab for each instance found in the remaining rows. This macro will be running against as many as 32,000 rows of data like this!

So when you open the spreadsheet, be sure to select Enable Macros when it opens and asks that question.
Then just do an Alt-F8 to run the macro, and enter in the word cups.
It is supposed to return 3 instances on the Extracted tab, for the attached worksheet testing.xls I am including. It should find 3 instances of the word cups in 3 rows and copy those full rows to the Extracted data tab.

When I run the macro, it only finds the 1st instance of "Cups" which is Monster Jam cups and then writes the entire row to the Extracted Data Tab nicely, but then stops and does not continue on to the bottom of the spreadsheet to check the remaining rows for the same string and copy those instances of the rows to the Extracted data tab like it did the first time.

I am running Windows XP Service Pack 2.
I am using Office 2002 Excel Ver 10.2.....

Any help greatly appreciated. Thank you!

Since I could not figure out how to attach the worksheet, I have attached an image of the spreadsheet and the Extracted Results Tab that works today as described above.

Here's a link to the image of the Workbook Spreadsheet I am working with

Here's a link to the image of what the macro currently copies to the Extracted Data Tab working as designed, except it only copies the row of 1st instance of the string found in the spreadsheet, it does not check all the rows as desired. It stops after 1st instance.

Here is my VB Macro code I am using now that works, but stops after the 1st instance is found, just need it to read the rest of the rows in the worksheet:

Private Function SheetExists(Sheetname As String) As Boolean
' Returns TRUE if a sheet exists in the active workbook
Dim x As Worksheet
On Error Resume Next
Set x = ActiveWorkbook.Sheets(Sheetname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
Sub FindAllSheets()
Dim Found As Range, ws As Worksheet, LookFor As Variant
LookFor = InputBox("Enter value to find")

If LookFor = "" Then Exit Sub

' Clear or Add a Results sheet
If SheetExists("Extracted Data") Then
Sheets("Extracted Data").Activate
Range("G2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Else
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Extracted Data"
End If

For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Extracted Data" Then
Set Found = ws.Cells.Find(What:=LookFor)
If Found Is Nothing Then
Range("G55").Select
Else
Found.EntireRow.Copy Sheets("Extracted Data").Cells(Rows.Count, "A").End(xlUp).Offset(0)
End If
End If
Next ws
End Sub



Any help greatly appreciated.
Thanks, Dave

 

[BoaterDave]

Sorry, here's macro code with code tags to make it easier to read and modify. Thanks for any help, much appreciated!

Private Function SheetExists(Sheetname As String) As Boolean
    ' Returns TRUE if a sheet exists in the active workbook
    Dim x As Worksheet
        On Error Resume Next
            Set x = ActiveWorkbook.Sheets(Sheetname)
                If Err = 0 Then SheetExists = True _
                Else SheetExists = False
End Function
Sub FindAllSheets()
    Dim Found As Range, ws As Worksheet, LookFor As Variant
        LookFor = InputBox("Enter value to find")
            
            If LookFor = "" Then Exit Sub
            
            '   Clear or Add a Results sheet
            If SheetExists("Extracted Data") Then
              Sheets("Extracted Data").Activate
              Range("G2").Select
              Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
              Selection.ClearContents
            Else
                Sheets.Add After:=Sheets(Sheets.Count)
                ActiveSheet.Name = "Extracted Data"
            End If
            
            For Each ws In ActiveWorkbook.Worksheets
                If ws.Name <> "Extracted Data" Then
                     Set Found = ws.Cells.Find(What:=LookFor)
                     If Found Is Nothing Then
                         Range("G55").Select
                     Else
                         Found.EntireRow.Copy Sheets("Extracted Data").Cells(Rows.Count, "A").End(xlUp).Offset(0)
                     End If
                End If
            Next ws
End Sub

 

[dodger7]

Hi Dave,

try this code:

Private Function SheetExists(Sheetname As String) As Boolean
' Returns TRUE if a sheet exists in the active workbook
Dim x As Worksheet
On Error Resume Next
Set x = ActiveWorkbook.Sheets(Sheetname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
Sub FindAllSheets()
    Dim FirstAddress As String
    Dim strFind As String
    Dim rSearch As Range
    Dim ws As Worksheet
    
    strFind = InputBox("Enter value to find")
    If strFind = "" Then Exit Sub
        
    If SheetExists("Extracted Data") Then
              Sheets("Extracted Data").Activate
              Range("a2").Select
              Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
              Selection.ClearContents
              Range("a1").Select
    Else
              Sheets.Add After:=Sheets(Sheets.Count)
              ActiveSheet.Name = "Extracted Data"
    End If
            
    For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Extracted Data" Then
    ws.Activate
    Set rSearch = ws.Range("g1", Range("g65536").End(xlUp))
    With rSearch
        Set c = .Find(strFind, LookIn:=xlValues)
        If Not c Is Nothing Then
          FirstAddress = c.Address
            Do
              c.EntireRow.Copy Sheets("Extracted Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
              Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
    End If
    End With
End If
Next ws
End Sub

 

[BoaterDave]

Dodger 7, YOU NAILED IT!
PERFECTION.
Thanks a million, I worked on this for weeks and could not solve it.
I can not tell you how much I appreciate the fix,
Thanks SO VERY MUCH!
Happy Holidays to you and yours, again much appreciated sir!
Dave

 

[dodger7]

Not a problem mate, seasons greetings