Search All worksheets for string & Create new Whorsheet with the Original Sheet Name and some cells.

[Dennis Whaley]

I am running Excel 97 SR-1.
Here is what I want to do:
I have a workbook that has many worksheets- all the sheets are in the
same format.
I would like to be able to search through the entire workbook and copy
all rows that contain my "FIND DATA" to a new worksheet. The find data
is really a name.
Here are the specifics -
The new worksheet would have the original(found) worksheet name in
cell A, and all the data from the original cells ,in cells B through
J, put in cells b through J.

I am working on a macro to do this, but I am not having too much luck.
I have searched this groups posting, and I can't find exactly what I
want, and assistance would be appreciated.

Thanks- Dennis

 

[Bernie Deitrick]

Dennis,

Try the macro below.

HTH,
Bernie

Sub CreateSummary()
Dim mySheet As Worksheet
Dim mySummary As Worksheet
Dim myCell As Range
Dim FirstCell As String
Dim myFindStr As String

myFindStr = "FIND DATA"

On Error Resume Next
Worksheets("Summary").Delete

Worksheets.Add.Name = "Summary"
Set mySummary = Worksheets("Summary")

For Each mySheet In Worksheets
FirstCell = ""
If mySheet.Name <> "Summary" Then
Set myCell = mySheet.Range("A:A").Find(myFindStr)
If Not myCell Is Nothing Then
FirstCell = myCell.Address
myCell.Offset(0, 1).Resize(1, 9).Copy _
mySummary.Range("B65536").End(xlUp)(2)
mySummary.Range("A65536").End(xlUp)(2).Value =
mySheet.Name
Set myCell = mySheet.Range("A:A").FindNext(myCell)
While Not myCell Is Nothing And myCell.Address <>
FirstCell
myCell.Offset(0, 1).Resize(1, 9).Copy _
mySummary.Range("B65536").End(xlUp)(2)
mySummary.Range("A65536").End(xlUp)(2).Value =
mySheet.Name
Set myCell = mySheet.Range("A:A").FindNext(myCell)
Wend
End If
End If
Next mySheet
End Sub

 

[Dennis Whaley]

Bernie,
Thank you very much- This is exactly what I wanted. There is just
one more thing- I only want to copy the Values-not any formatting.
What needs to be changed? I tried to make chnages. but none of them
worked.

 

[Bernie Deitrick]

Dennis,

Use the version below.

HTH,
Bernie

Sub CreateSummaryValuesOnly()
Dim mySheet As Worksheet
Dim mySummary As Worksheet
Dim myCell As Range
Dim FirstCell As String
Dim myFindStr As String

myFindStr = "Bernie"

On Error Resume Next
Worksheets("Summary").Delete

Worksheets.Add.Name = "Summary"
Set mySummary = Worksheets("Summary")

For Each mySheet In Worksheets
FirstCell = ""
If mySheet.Name <> "Summary" Then
Set myCell = mySheet.Range("A:A").Find(myFindStr)
If Not myCell Is Nothing Then
FirstCell = myCell.Address
myCell.Offset(0, 1).Resize(1, 9).Copy
mySummary.Range("B65536").End(xlUp)(2).PasteSpecial
xlValues
mySummary.Range("A65536").End(xlUp)(2).Value =
mySheet.Name
Set myCell = mySheet.Range("A:A").FindNext(myCell)
While Not myCell Is Nothing And myCell.Address <>
FirstCell
myCell.Offset(0, 1).Resize(1, 9).Copy

mySummary.Range("B65536").End(xlUp)(2).PasteSpecial xlValues
mySummary.Range("A65536").End(xlUp)(2).Value =
mySheet.Name
Set myCell = mySheet.Range("A:A").FindNext(myCell)
Wend
End If
End If
Next mySheet
End Sub