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

  • Thread starter Thread starter Dennis Whaley
  • Start date Start date
D

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
 
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
 
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.
 
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
 
Back
Top