creating new workbook from single worksheet

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Hi,
I have a worksheet with multiple reports in it. Each report has report name, description and columns, I've copied a sample below. How can create a new workbook for each report.

Summary of Advertisers, Revenue and QCEs
South Hampton Roads Market
Source: STARS / ICVP, 12/10/2003 (Tompkins)

MARKET MARKET_NAME REV01 REV02 REV03 REVGAIN02
76618 SOUTH HAMPTON RDS 2,362,440 2,387,894 3,167,806 1.1%
76642 PENINSULA 1,632,760 1,711,185 1,268,229 4.8%
76842 SUFFOLK 310,437 295,856 4,906 -4.7%

4,305,637 4,394,934 4,440,942 2.1%


Summary of Advertiser Activity
South Hampton Roads Market
Source: STARS / ICVP, 12/10/2003 (Tompkins)

PUB_YR MARKET MARKET_NAME STARTING_REVENUE ENDING_REVENUE START_ADVERTS
2000 76618 SOUTH HAMPTON RDS 2,151,773 2,295,891 7,073
2000 76642 PENINSULA 1,563,321 1,620,962 3,790
2000 76842 SUFFOLK 294,974 313,986 415
4,010,068 4,230,839 11,278



Thanks!
Shaun
 
do a loop that finds each occurance of the word 'summary'

the first occurance is the row of the "header", and the
line above the next is th e"footer", if there's no next
then the "footer" row wll be the last row +2

now you know the first and last row of the data, just
copy then to a new sheet.

here's a few lines of code that worked ok with your
snippet:-

Sub Extract()
Dim sFind As String
Dim ThisWS As Worksheet
Dim NewWS As Worksheet
Dim StartCell As Range
Dim NextCell As Range
Dim firstAdd As String
Dim firstrow As Long
Dim lastrow As Long
sFind = "Summary"
Set ThisWS = ActiveSheet

Set StartCell = ThisWS.Cells.Find(sFind)

If Not StartCell Is Nothing Then
firstAdd = StartCell.Address
Do
firstrow = StartCell.Row
Set NextCell = ThisWS.Cells.FindNext
(StartCell)

If NextCell Is Nothing Or NextCell.Address =
firstAdd Then
lastrow = ThisWS.Range("A65000").End
(xlUp).Row + 2
Else
lastrow = NextCell.Row - 1
End If

Set NewWS = Worksheets.Add

ThisWS.Range(firstrow & ":" & lastrow).Copy
NewWS.Range("A1").PasteSpecial xlPasteAll

Set StartCell = NextCell
Loop Until StartCell.Address = firstAdd Or
StartCell Is Nothing

End If





End Sub


Patrick Molloy
Microsoft Excel MVP


-----Original Message-----
Hi,
I have a worksheet with multiple reports in it. Each
Click to expand...
report has report name, description and columns, I've
copied a sample below. How can create a new workbook for
each report.
Summary of Advertisers, Revenue and QCEs
Click to expand...
South Hampton Roads Market
Click to expand...
Source: STARS / ICVP, 12/10/2003 (Tompkins)
Click to expand...
MARKET MARKET_NAME REV01 REV02 REV03 REVGAIN02
76618 SOUTH HAMPTON RDS 2,362,440 2,387,894 3,167,806 1.1%
76642 PENINSULA 1,632,760 1,711,185 1,268,229 4.8%
76842 SUFFOLK 310,437 295,856 4,906 - 4.7%

4,305,637 4,394,934 4,440,942 2.1%


Summary of Advertiser Activity
Click to expand...
 
Thanks Patrick, the code you provided was awesome and it does amlost exactly what I need it to do. The only problem is it doesn't pick up the first and last reports. I received a 'Method Range of object worksheet failed error'. I did get a new sheet for 6 of the 8 reports on the spreadsheet.

Shaun
----- Patrick Molloy wrote: -----

do a loop that finds each occurance of the word 'summary'

the first occurance is the row of the "header", and the
line above the next is th e"footer", if there's no next
then the "footer" row wll be the last row +2

now you know the first and last row of the data, just
copy then to a new sheet.

here's a few lines of code that worked ok with your
snippet:-

Sub Extract()
Dim sFind As String
Dim ThisWS As Worksheet
Dim NewWS As Worksheet
Dim StartCell As Range
Dim NextCell As Range
Dim firstAdd As String
Dim firstrow As Long
Dim lastrow As Long
sFind = "Summary"
Set ThisWS = ActiveSheet

Set StartCell = ThisWS.Cells.Find(sFind)

If Not StartCell Is Nothing Then
firstAdd = StartCell.Address
Do
firstrow = StartCell.Row
Set NextCell = ThisWS.Cells.FindNext
(StartCell)

If NextCell Is Nothing Or NextCell.Address =
firstAdd Then
lastrow = ThisWS.Range("A65000").End
(xlUp).Row + 2
Else
lastrow = NextCell.Row - 1
End If

Set NewWS = Worksheets.Add

ThisWS.Range(firstrow & ":" & lastrow).Copy
NewWS.Range("A1").PasteSpecial xlPasteAll

Set StartCell = NextCell
Loop Until StartCell.Address = firstAdd Or
StartCell Is Nothing

End If





End Sub


Patrick Molloy
Microsoft Excel MVP


-----Original Message-----
Hi,
I have a worksheet with multiple reports in it. Each
Click to expand...
report has report name, description and columns, I've
copied a sample below. How can create a new workbook for
each report.
South Hampton Roads Market
Click to expand...
Source: STARS / ICVP, 12/10/2003 (Tompkins)
76618 SOUTH HAMPTON RDS 2,362,440 2,387,894 3,167,806 1.1%
76642 PENINSULA 1,632,760 1,711,185 1,268,229 4.8%
76842 SUFFOLK 310,437 295,856 4,906 - 4.7%
Click to expand...
 
There's a slight problem if your data starts in A1 (or row 1, I bet).

Try changing this line:

Set StartCell = ThisWS.Cells.Find(sFind)

to:

With ThisWS
Set StartCell = .Cells.Find(sFind, after:=.Cells(.Cells.Count))
End With

Then you'll be working from the top, down.

(In fact, I'd specify almost every option in the .find:

With ThisWS
Set StartCell = .Cells.Find(what:=sFind, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlPart, _
searchdirection:=xlNext, _
searchorder:=xlByRows, _
MatchCase:=False)
End With

..find is one of those things that remembers the last .find's parms--even if the
user did it manually.
 
Back
Top