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]

I made a couple of mods but did not test it. See if it will work for you and post back if not.

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
    Windows.View = xlPageBreaksPreview 
    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("B" & HPB.Location.Row).End(xlDown).Value
 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)
        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

 

[sharicn]

Thanks for the help! When I ran it I got runtime error 438: Object doesn't support this property or method

on the following line:

Windows.View = xlPageBreaksPreview

Any ideas?

 

[JLGWhiz]

Change that 'Windows.View' to 'ActiveWindow.View'

 

[sharicn]

Hmmm...now I get Runtime Error 1004: Application-defined or object-defined error

on the same line.

 

[JLGWhiz]

xlPageBreakPreview.
Delete the 's'. Sorry about the typos.

 

[sharicn]

No problem - I am very grateful for the help. It seems to be working now, though still not doing exactly what I had hoped for. It split out the first firm (Ater Wynne) into its own worksheet (named "Grand Total") but the formatting (such as landscape) did not carry over, nor did the page header. Row A1 copied over though, which is perfect. I'm not sure why it didn't continue to copy the next firm to its own sheet??

Sorry to be so helpless. Like I said, I really appreciate the assistance. I've gotten some amazing help here before that has made my life so much easier.

 

[JLGWhiz]

No problem - I am very grateful for the help. It seems to be working now, though still not doing exactly what I had hoped for. It split out the first firm (Ater Wynne) into its own worksheet (named "Grand Total") but the formatting (such as landscape) did not carry over, nor did the page header. Row A1 copied over though, which is perfect. I'm not sure why it didn't continue to copy the next firm to its own sheet??

Sorry to be so helpless. Like I said, I really appreciate the assistance. I've gotten some amazing help here before that has made my life so much easier.

You can open the VB editor, click anywhere inside the procedure then use F8 function key to step through the procedure and see what it does as the yellow highlight progresses. Hovering the mouse pointer over variables will display values in the 'Tool Tips' pop up. Maybe you can figure out why it is not getting the second firm.

 

[sharicn]

Thanks for the tip - will do!

 

[sharicn]

That was helpful - I figured out that it wasn't getting the final firm because I was missing the final page break after the final firm. Easy fix there. I also altered the code so that it would put the correct name on the worksheet, since the firm name will appear in cell B2 every time.

Remaining issues: It's copying row A1 to the first worksheet, but not the subsequent ones. It's also asking me to manually name every subsequent worksheet after the first one, and it's not copying formatting from the first worksheet (landscape, column widths, header/footer, etc). Not sure if the formatting part is even possible and, if not, it's not that big a deal - pretty easily fixable by selecting the first worksheet and all subsequent ones and editing the page options for all.

Sorry to be such a pain, and really appreciate your help. Let me know if there's any other information I can provide that would be more helpful.