Solved: Search multiple sheets and copy results to another sheet

[Shaolin1976]

Hi,

Firstly, many thanks to Tecnik for the helpful links in http://vbaexpress.com/forum/showthread.php?t=7910

I have been trying to modify a macro found on one of Tecnik's links which searches a column in the activesheet and copies the results to an different sheet.

I have a search sheet (imaginatively named "SEARCH") and numerous other sheets (named 1 through to 100) which contain the data which is to be searched. I would like to have the macro (located on a button in the "SEARCH" sheet) search column A in all other sheets and paste each row where it finds a match into the SEARCH sheet.

I have been trying to get this to work for just one sheet (Sheet 88) to start with and then go from there to make it search all sheets but I keep geting an error on Line 20 and I really haven't a clue as to why. Any help as to why the error keeps occuring and also how I'd go about making it search all other sheets in the workbook would be greatly appreciated. Ideally I would like to have an input box from which I can enter the value to be searched but thats only if the following code works without throwing up an error first!

[vba]Public Sub SearchButton_Click()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 2
LSearchRow = 2

'Start copying data to row 2 in SEARCH (row counter variable)
LCopyToRow = 2

While Len(Sheets("88").Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column A = "Test", copy entire row to SEARCH
If Sheets("88").Range("A" & CStr(LSearchRow)).Value = "Test" Then

'Select row in Sheet 88 to copy
Sheets(88).Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into SEARCH in next row
Sheets("SEARCH").Select
Sheets("SEARCH").Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet 88 to continue searching
Sheets("88").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Sheets("SEARCH").Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub[/vba]Many thanks

Shaolin

[johnske]

Try this...
[vba]
Option Explicit
Option Compare Text '< ignore case
'
Sub SearchSheets()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
'
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If WhatFor = Empty Then Exit Sub
'
For Each Sheet In Sheets
If Sheet.Name <> "SEARCH" Then
With Sheet.Columns(1)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Cell.EntireRow.Copy _
Destination:=Sheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
'
Set Cell = Nothing
End Sub
[/vba]

[Shaolin1976]

Hi Johnske,

Thanks for your reply, your code works fine in that it searches the other sheets but it only throws up the first match. It stops once it has found the first match; it doesnt loop through the rest of the hits on that sheet and subsequent sheets and paste them all to the SEARCH sheet.

Many thanks again

Shaolin

[lucas]

it does search subsequent sheets but it does stop at the first one it finds on each sheet....

[Shaolin1976]

I just played about with it a little more and yes, it does copy the first match from each sheet but not multiple matches from each sheet. Is there an easy fix to make it find each and every match on each sheet?

[Shaolin1976]

EDIT: Sorry, ignore this post

[johnske]

Sorry, my oops, a line was accidentally deleted - this'll work...

[VBA]
Option Explicit
Option Compare Text '< ignore case
'
Sub SeachSheets()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
'
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If WhatFor = Empty Then Exit Sub
'
For Each Sheet In Sheets
If Sheet.Name <> "SEARCH" Then
With Sheet.Columns(1)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Cell.EntireRow.Copy _
Destination:=Sheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
'
Set Cell = Nothing
End Sub
[/VBA]

[Shaolin1976]

That works PERFECTLY, many thanks Johnske, this is going to save me quite a bit of time searching through endless columns. I sincerely appreciate your help.

Now to try and figure out why your code works heh

Shaolin

[lucas]

Thats slick and handy John, add it to the kb?

[lucas]

John, if you wanted to search for cells with an exact string this can be changed:
[VBA]
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
[/VBA]to this
[VBA]
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)
[/VBA]correct?

[johnske]

Thats slick and handy John, add it to the kb?

Not at this stage Steve. Might wait for the next KB contest, I've got forty or fifty in hand for that

Yeh, can easily make it xlWhole if wanted, but ppl are usually satisfied with a partial match

[lucas]

I'll be yoinking it and using it in the meantime..Thanks

[please_help]

Can someone please help me modify the code to
copy only the row with search string "IF" the cell in
Sheet.Columns(6) is greater than zero?


Thanks in advance

[vba]
Option Explicit
Option Compare Text '< ignore case
'
Sub SearchSheets()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
'
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If WhatFor = Empty Then Exit Sub
'
For Each Sheet In Sheets
If Sheet.Name <> "SEARCH" Then
With Sheet.Columns(7)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Cell.EntireRow.Copy _
Destination:=Sheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
'
Set Cell = Nothing
End Sub
[/vba]

[Paul_Hossler]

Welcome to the forum - take a minute and look at the FAQs at the link in my signature

You'd be MUCH better off by starting your own thread instead of hijacking a 15 year old one that has already been marked [SOLVED]

You could just reference the old one in your post

Also, you can add CODE tags (replaced [vba] tags long time ago) by clicking the [#] icon and then pasting your macro between


Capture.JPG