Splitting data into several worksheets based on page breaks - help with VBA macro

[sharicn]

Hello,

I am a novice when it comes to VBA - I can usually modify code that I find in forums such as these to get it to work for my circumstances, but I'm not great at creating my own. I'm hoping that someone can help me with a macro to split some data into separate worksheets based on page breaks. I have data that is subtotaled by firm and divided with a page break. Ideally, what I'd like to do is to put each firm in a separate worksheet that retains the same formatting, header, and top header row (A1) as the initial worksheet, with each of the worksheets being named for the firm whose data it contains.

I've managed to find some code that splits the page into separate worksheets, but it does not have all the bells and whistles I mentioned above. The code is below, along with a sample from my worksheet, and I'm hoping that someone can help me modify it. It would make my life so much easier, especially since the database from which I am pulling my data has limitations of its own, which is what makes me want to pull the information into Excel in the first place instead of running one of its "canned" reports.

Thanks in advance for any help you can provide,
Shari

Sub Create_Separate_Sheet_For_Each_HPageBreak()
    Dim HPB As HPageBreak
    Dim RW As Long
    Dim PageNum As Long
    Dim Asheet As Worksheet
    Dim Nsheet As Worksheet
    Dim Acell As Range
 
    'Sheet with the data, you can also use Sheets("Sheet1")
    Set Asheet = ActiveSheet
 
    If Asheet.HPageBreaks.Count = 0 Then
        MsgBox "There are no HPageBreaks"
        Exit Sub
    End If
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    'When the macro is ready we return to this cell on the ActiveSheet
    Set Acell = Range("A1")
 
    'Because of this bug we select a cell below your data
    'http://support.microsoft.com/default.aspx?scid=kb;en-us;210663
    Application.Goto Asheet.Range("A" & Rows.Count), True
 
    RW = 1
    PageNum = 1
 
    For Each HPB In Asheet.HPageBreaks
    If HPB.Type = xlPageBreakManual Then
   
        'Add a sheet for the page
        With Asheet.Parent
            Set Nsheet = Worksheets.Add(After:=.Sheets(.Sheets.Count))
        End With
 
        'Give the sheet a name
        On Error Resume Next
        Nsheet.Name = "Page " & PageNum
        If Err.Number > 0 Then
            MsgBox "Change the name of : " & Nsheet.Name & " manually"
            Err.Clear
        End If
        On Error GoTo 0
 
        'Copy the cells from the page into the new sheet
        With Asheet
            .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy _
                    Nsheet.Cells(1)
        End With
        ' If you want to make values of your formulas use this line also
        ' Nsheet.UsedRange.Value = Nsheet.UsedRange.Value
 
        RW = HPB.Location.Row
        PageNum = PageNum + 1
        End If
    Next HPB
 
    Asheet.DisplayPageBreaks = False
    Application.Goto Acell, True
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Name	Firm	Firmmember	2014 direct gifts, pledges, or matches	2014 soft credits not from the firm (count towards total)	2014 soft credits from the firm (do not count towards total)	2013 direct gifts, pledges, or matches	2013 soft credits not from the firm (count towards total)	2013 soft credits from the firm (do not count towards total)
John Smith	Ater Wynne	Associate	$20.00			$40.00		$140.00
John Smith	Ater Wynne	Associate	$20.00
John Smith	Ater Wynne	Associate
John Smith	Ater Wynne	Associate	$20.00			$50.00		$150.00
John Smith	Ater Wynne	Associate	$20.00			$100.00		$200.00
John Smith	Ater Wynne	Associate				$70.00		$170.00
John Smith	Ater Wynne	Associate	$20.00			$120.00		$220.00
	Associate Count	7
Ater Wynne LLP	Ater Wynne	Firm				$10,215.00
	Firm Count	1
Jane Smith	Ater Wynne	Partner				$700.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$250.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$100.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$150.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$700.00		$300.00
Jane Smith	Ater Wynne	Partner				$20.00		$300.00
Jane Smith	Ater Wynne	Partner				$50.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$25.00		$300.00
Jane Smith	Ater Wynne	Partner				$20.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$200.00		$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner						$300.00
Jane Smith	Ater Wynne	Partner				$100.00		$300.00
	Partner Count	26
Jim Smith	Ater Wynne	Senior Counsel				$250.00		$300.00
Jim Smith	Ater Wynne	Senior Counsel						$1,800.00
Jim Smith	Ater Wynne	Senior Counsel						$300.00
	Senior Counsel Count	3
Joan Smith	Ater Wynne	Staff				$15.00
Joan Smith	Ater Wynne	Staff
Joan Smith	Ater Wynne	Staff				$10.00
Joan Smith	Ater Wynne	Staff
Joan Smith	Ater Wynne	Staff
	Staff Count	5
	Ater Wynne Total		$100.00	$0.00	$0.00	$13,185.00	$0.00	$11,080.00
John Smith	Barran Liebman	Associate	$300.00		$700.00	$300.00		$700.00
John Smith	Barran Liebman	Associate	$300.00		$700.00	$300.00		$700.00
John Smith	Barran Liebman	Associate	$300.00		$700.00	$340.00		$700.00
John Smith	Barran Liebman	Associate	$300.00		$700.00	$50.00
John Smith	Barran Liebman	Associate	$320.00		$700.00	$10.00
John Smith	Barran Liebman	Associate	$320.00		$700.00	$320.00		$700.00
John Smith	Barran Liebman	Associate	$320.00		$700.00		$525.00	$725.00
	Associate Count	7
Barran Liebman LLP	Barran Liebman	Firm	$17,925.00			$17,150.08
	Firm Count	1
Jane Smith	Barran Liebman	Of Counsel
	Of Counsel Count	1
Jim Smith	Barran Liebman	Partner			$1,250.00			$1,250.00
Jim Smith	Barran Liebman	Partner			$1,250.00			$1,250.00
Jim Smith	Barran Liebman	Partner			$1,250.00			$1,250.00
Jim Smith	Barran Liebman	Partner	$5,075.00			$6,265.00
Jim Smith	Barran Liebman	Partner			$1,250.00			$2,575.00
Jim Smith	Barran Liebman	Partner			$1,250.00			$1,250.00
Jim Smith	Barran Liebman	Partner			$1,250.00			$1,250.00
Jim Smith	Barran Liebman	Partner			$1,250.00			$1,250.00
Jim Smith	Barran Liebman	Partner			$1,500.00	$40.00		$1,500.00
Jim Smith	Barran Liebman	Partner			$1,250.00	$300.00		$700.00
	Partner Count	10
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff				$80.00		$50.00
Joan Smith	Barran Liebman	Staff	$300.00		$700.00	$310.00		$700.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
Joan Smith	Barran Liebman	Staff						$50.00
	Staff Count	13
	Barran Liebman Total		$25,460.00	$0.00	$17,100.00	$25,465.08	$525.00	$17,100.00

<tbody>
</tbody>

Header reads as follows:

Confidential Information	Campaign for Equal Justice	Please Do Not Distribute
	Firm Report
	&[Date]

<tbody>
</tbody>

 

[JLGWhiz]

1. It's copying row A1 to the first worksheet, but not the subsequent ones.
2. It's also asking me to manually name every subsequent worksheet after the first one,
3. it's not copying formatting from the first worksheet (landscape, column widths, header/footer, etc).

1. & 2. I would need to see the code as you have revised it to before attempting to analyze 1 and 2 above.
3. Landscape is not a format property, it is a page set up property and will not transfer with a copy method. The new sheet will use whatever your default setting is. Your option is to add a line of code like:

Nsheet.PageSetup.Orientation = xlLandscape

after the new sheet is created.
I have not dealt with headers and footers in a long time, but I would assume that they are similar to landscape and are not part of the Formats collection. Which means you would also need code to add those back into each sheet. See 'Formatting and VBA Codes for Headers and Footers' in VBA help files in the VB Editor. You have six options of headers and footers that you can use.
For the other formatting, you would have to use PasteSpecial method instead of the direct copy/paste method.
Change this:

With Asheet
   .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy _
      Nsheet.Cells(1)
End With

to this:

With Asheet
            .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy 
            Nsheet.Cells(1).PasteSpecial xlPasteAll
End With

Note that the underscore line is removed in the PasteSpecial method.

 

[sharicn]

Thanks so much for the tips on landscape, headers, and paste special. I've managed to get that part worked out. Here is the code I have now; hopefully you can help with those first two issues. Let me know if there is a way I can get my Excel file to you, if you think that would be helpful. You are not only helping me with my issue, but helping me to learn as well, and I do appreciate it.

Sub Create_Separate_Sheet_For_Each_HPageBreak2()
    Dim HPB As HPageBreak
    Dim RW As Long
    Dim PageNum As Long
    Dim Asheet As Worksheet
    Dim Nsheet As Worksheet
    Dim Acell As Range
    'Sheet with the data, you can also use Sheets("Sheet1")
    Set Asheet = ActiveSheet
    ActiveWindow.View = xlPageBreakPreview
    If Asheet.HPageBreaks.Count = 0 Then
        MsgBox "There are no HPageBreaks"
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'When the macro is ready we return to this cell on the ActiveSheet
    Set Acell = Range("A1")
    'Because of this bug we select a cell below your data
    'http://support.microsoft.com/default.aspx?scid=kb;en-us;210663
    Application.Goto Asheet.Range("A" & Rows.Count), True
    RW = 1
    PageNum = 1
    For Each HPB In Asheet.HPageBreaks
    If HPB.Type = xlPageBreakManual Then
        'Add a sheet for the page
        With Asheet.Parent
            Set Nsheet = Worksheets.Add(After:=.Sheets(.Sheets.Count))
        End With
        'Give the sheet a name
        On Error Resume Next
        Nsheet.Name = Asheet.Range("B2")
 Asheet.Rows(1).Copy Nsheet.Range("A1")
        If Err.Number > 0 Then
            MsgBox "Change the name of : " & Nsheet.Name & " manually"
            Err.Clear
        End If
        On Error GoTo 0
        'Copy the cells from the page into the new sheet
With Asheet
            .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy
            Nsheet.Cells(1).PasteSpecial xlPasteAll
End With
 
        ' If you want to make values of your formulas use this line also
        ' Nsheet.UsedRange.Value = Nsheet.UsedRange.Value
        RW = HPB.Location.Row
        'PageNum = PageNum + 1
        End If

 With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$1"
    .LeftMargin = Application.InchesToPoints(0.25)
    .RightMargin = Application.InchesToPoints(0.25)
    .TopMargin = Application.InchesToPoints(0.85)
    .BottomMargin = Application.InchesToPoints(0.5)
    .HeaderMargin = Application.InchesToPoints(0.25)
    .FooterMargin = Application.InchesToPoints(0.25)
    .Orientation = xlLandscape
    .LeftHeader = "Confidential Information"
    .CenterHeader = "Campaign for Equal Justice" & Chr(13) & Format(ActiveSheet.Range("B2").Value) & Chr(13) & "Firm Report - &D"
    .RightHeader = "Please Do Not Distribute"
    .CenterFooter = "Page &P of &N"
End With    Next HPB
    Asheet.DisplayPageBreaks = False
    Application.Goto Acell, True
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[JLGWhiz]

It looks like you are getting an error and the 'On Error Resume Next' is preventing the error message from showing. This version uses a different trap which will show on which line the error occurs and what the error is. Then we can work from that to fix the problem. I also added the property Value on the line that assigns the sheet name. That may or may not fix that problem. Note any errors that are reported as you run the code and whether they are for the sheet name or the header copy.

Sub Create_Separate_Sheet_For_Each_HPageBreak2()
    Dim HPB As HPageBreak
    Dim RW As Long
    Dim PageNum As Long
    Dim Asheet As Worksheet
    Dim Nsheet As Worksheet
    Dim Acell As Range
    'Sheet with the data, you can also use Sheets("Sheet1")
    Set Asheet = ActiveSheet
    ActiveWindow.View = xlPageBreakPreview
    If Asheet.HPageBreaks.Count = 0 Then
        MsgBox "There are no HPageBreaks"
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'When the macro is ready we return to this cell on the ActiveSheet
    Set Acell = Range("A1")
    'Because of this bug we select a cell below your data
    'http://support.microsoft.com/default.aspx?scid=kb;en-us;210663
    Application.Goto Asheet.Range("A" & Rows.Count), True
    RW = 1
    PageNum = 1
    For Each HPB In Asheet.HPageBreaks
    If HPB.Type = xlPageBreakManual Then
        'Add a sheet for the page
        With Asheet.Parent
            Set Nsheet = Worksheets.Add(After:=.Sheets(.Sheets.Count))
        End With
        'Give the sheet a name
        On Error GoTo ANAL1:
        Nsheet.Name = Asheet.Range("B2").Value
ANAL1:
  If Err.Number > 0 Then
   MsgBox Err.Number & ":  " & Err.Description & "Error on sheet name"
   Err.Clear
  End If
 On Error GoTo ANAL2:
  Asheet.Rows(1).Copy Nsheet.Range("A1")
ANAL2:
        If Err.Number > 0 Then 
            MsgBox Err.Number & ":  " & Error.Description & "Change the name of : " & Nsheet.Name & " manually"
            Err.Clear
        End If       
        'Copy the cells from the page into the new sheet
With Asheet
            .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy
            Nsheet.Cells(1).PasteSpecial xlPasteAll
End With 
        ' If you want to make values of your formulas use this line also
        ' Nsheet.UsedRange.Value = Nsheet.UsedRange.Value
        RW = HPB.Location.Row
        'PageNum = PageNum + 1
        End If
 With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$1"
    .LeftMargin = Application.InchesToPoints(0.25)
    .RightMargin = Application.InchesToPoints(0.25)
    .TopMargin = Application.InchesToPoints(0.85)
    .BottomMargin = Application.InchesToPoints(0.5)
    .HeaderMargin = Application.InchesToPoints(0.25)
    .FooterMargin = Application.InchesToPoints(0.25)
    .Orientation = xlLandscape
    .LeftHeader = "Confidential Information"
    .CenterHeader = "Campaign for Equal Justice" & Chr(13) & Format(ActiveSheet.Range("B2").Value) & Chr(13) & "Firm Report - &D"
    .RightHeader = "Please Do Not Distribute"
    .CenterFooter = "Page &P of &N"
End With    Next HPB
    Asheet.DisplayPageBreaks = False
    Application.Goto Acell, True
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[sharicn]

Interesting. Now I receive the following error: "Run-time Error '1004' Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic"

This happens after it pastes the information into the first new sheet and creates the second sheet -- stops at the last line at this point in the code:

ANAL1:
  If Err.Number > 0 Then
   MsgBox Err.Number & ":  " & Err.Description & "Error on sheet name"
   Err.Clear

 

[JLGWhiz]

Interesting. Now I receive the following error: "Run-time Error '1004' Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic"

This happens after it pastes the information into the first new sheet and creates the second sheet -- stops at the last line at this point in the code:

ANAL1:
  If Err.Number > 0 Then
   MsgBox Err.Number & ":  " & Err.Description & "Error on sheet name"
   Err.Clear

I wondered about that when you said the Firm name would always be in cell B2. The sample data that you put up showed that the firm name changed after each pagebreak and is why i had the offset statement in there. I was trying to get the name in column B since it looked like the Firm name would be in that column for the entire page, until the next page break.
This statement:

Nsheet.Name = Asheet.Range("B" & HPB.Location.Row).End(xlDown).Value

should go to column B on the same row as the pagebreak, then find the first cell with date below that, which should be the firm name for that page. Try changing that back and see if it still gives the error.