+ Reply to Thread
Results 1 to 7 of 7

[Solved] Split into multiple sheets by page breaks, preserving formatting

Hybrid View

tecsbrain [Solved] Split into multiple... 10-01-2014, 03:06 PM
protonLeah Re: Split into multiple... 10-01-2014, 08:09 PM
tecsbrain Re: Split into multiple... 10-02-2014, 11:43 AM
protonLeah Re: Split into multiple... 10-03-2014, 11:23 PM
tecsbrain Re: Split into multiple... 10-07-2014, 11:34 AM
protonLeah Re: Split into multiple... 10-07-2014, 03:02 PM
tecsbrain Re: Split into multiple... 10-07-2014, 03:24 PM
  1. #1
    Registered User
    Join Date
    11-15-2010
    Location
    Arlington, VA
    MS-Off Ver
    Excel 365
    Posts
    34

    [Solved] Split into multiple sheets by page breaks, preserving formatting

    Hi,

    I am employing the solution at http://www.rondebruin.nl/win/s3/win005.htm in a worksheet to split the data of one massive worksheet into several, based on page breaks.

    However, the row height and column widths are not being preserved. I have figured a simple enough way to take care of column widths, but the row heights are tough because they don't follow a pattern.

    Is there any way to modify this routine to preserve the column widths and row heights when making the paste operation into the new sheets?

    Bonus points: Instead of doing this by page break, how could I do this via every instance of a phrase? Every page in the file has the same title, so maybe I can use that instead of creating page breaks in the first place.
    Last edited by tecsbrain; 10-07-2014 at 03:26 PM.

  2. #2
    Forum Guru
    Join Date
    03-02-2006
    Location
    Los Angeles, Ca
    MS-Off Ver
    WinXP/MSO2007;Win10/MSO2016
    Posts
    12,963

    Re: Split into multiple sheets by page breaks, preserving formatting

    To attach a Workbook
    (please do not post pictures or links to worksheets)
    • Click Advanced (next to quick post),
    • Scroll down until you see "Manage Attachments",
    • Click that then select "add files" (top right corner).
    • Click "Select Files" find your file, click "open" click "upload"
    • Once the upload is completed the file name will appear below the input boxes in this window.
    • Click "Done" at bottom right to close the Attachment Manager.
    • Click "Submit Reply"
    Ben Van Johnson

  3. #3
    Registered User
    Join Date
    11-15-2010
    Location
    Arlington, VA
    MS-Off Ver
    Excel 365
    Posts
    34

    Re: Split into multiple sheets by page breaks, preserving formatting

    Deleting my original reply -- I just decided to pay attention to the color of your text and noticed that you emphasized not to link to worksheets.

    I wasn't linking to the worksheet, just to a macro that I wanted to use. Apologies if that's against SOP, here's the code:

    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
            '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
        Next HPB
    
        Asheet.DisplayPageBreaks = False
        Application.Goto Acell, True
    
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End Sub
    Thanks!
    Attached Files Attached Files
    Last edited by tecsbrain; 10-03-2014 at 01:46 PM.

  4. #4
    Forum Guru
    Join Date
    03-02-2006
    Location
    Los Angeles, Ca
    MS-Off Ver
    WinXP/MSO2007;Win10/MSO2016
    Posts
    12,963

    Re: Split into multiple sheets by page breaks, preserving formatting

    Try this one (tested):
    Based on searching for header A1:C1 of first page

    Sub PageSeparator()
        Dim HeaderCount As Long, _
            CountNdx    As Long, _
            LastFound   As Variant, _
            LastRow     As Variant, _
            Found       As Variant, _
            TestCell    As Range
            
        Application.ScreenUpdating = False
            
        HeaderCount = [countif(A:A,A1)]
        LastRow = Sheets("All").Cells(Rows.Count, 1).End(xlUp).Row
    
        ' pageboundaries() holds the address of the found headers and the address of the cell just above the next one found
        ReDim PageBoundaries(1 To HeaderCount, 1 To 2) As String
    
        PageBoundaries(1, 1) = "A1"
        PageBoundaries(HeaderCount, 2) = "A" & LastRow
    
        With 
            LastFound = .Range("A1").Address(0, 0)
    
            For CountNdx = 2 To HeaderCount
                Set Found = .Find(What:=Range("A1").Value, _
                            LookAt:=xlPart, _
                            After:=Range(LastFound), _
                            SearchOrder:=xlByRows)
    
                If Found Is Nothing Then Exit For
    
                LastFound = Found.Address(0, 0)
                PageBoundaries(CountNdx - 1, 2) = Found.Offset(-1, 0).Address(0, 0) ' the last row is one row up from the next found header
                PageBoundaries(CountNdx, 1) = Found.Address(0, 0)
            Next CountNdx
    
        End With    'Sheets("all").Cells
    
        For CountNdx = 1 To HeaderCount
            Sheets("all").Range(PageBoundaries(CountNdx, 1), PageBoundaries(CountNdx, 2)).Select
            Selection.Copy
            Sheets.Add After:=Sheets(Sheets.Count)
            Selection.PasteSpecial _
                Paste:=xlPasteAll, _
                Operation:=xlNone, _
                SkipBlanks:= _
                False, Transpose:=False
    
            ActiveSheet.Name = Range("M6").Value
                
            'adjust column width of copied sheet to match sheet "all" column
    
            For Each TestCell In Range("A9:M9")
                TestCell.ColumnWidth = Sheets("All").Range(TestCell.Address).ColumnWidth
            Next TestCell
            
            'get the last row of the copied sheet
            Set LastRow = Cells(Rows.Count, 1).End(xlUp)
            
            'adjust the row height of the copied sheet to match the sheet "all row
    
            For Each TestCell In Range("A1", LastRow.Address)
                TestCell.RowHeight = Sheets("All").Range(TestCell.Address).RowHeight
            Next TestCell
    
            Range("A1").Select
            
            Sheets("All").Select
            Application.CutCopyMode = False
    
        Next CountNdx
    
        Application.ScreenUpdating = True
    End Sub
    Last edited by protonLeah; 10-04-2014 at 02:44 PM.

  5. #5
    Registered User
    Join Date
    11-15-2010
    Location
    Arlington, VA
    MS-Off Ver
    Excel 365
    Posts
    34

    Re: Split into multiple sheets by page breaks, preserving formatting

    This one gives me a "Compile Error: Syntax Error" with line 21 "With" highlighted. Any ideas? Tried adding it as a module and an object.

  6. #6
    Forum Guru
    Join Date
    03-02-2006
    Location
    Los Angeles, Ca
    MS-Off Ver
    WinXP/MSO2007;Win10/MSO2016
    Posts
    12,963

    Re: Split into multiple sheets by page breaks, preserving formatting

    Sorry, correction in RED below
    Sub PageSeparator()
        Dim HeaderCount As Long, _
            CountNdx    As Long, _
            LastFound   As Variant, _
            LastRow     As Variant, _
            Found       As Variant, _
            TestCell    As Range
            
        Application.ScreenUpdating = False
            
        HeaderCount = [countif(A:A,A1)]
        LastRow = Sheets("All").Cells(Rows.Count, 1).End(xlUp).Row
    
        ' pageboundaries() holds the address of the found headers and the address of the cell just above the next one found
        ReDim PageBoundaries(1 To HeaderCount, 1 To 2) As String
    
        PageBoundaries(1, 1) = "A1"
        PageBoundaries(HeaderCount, 2) = "A" & LastRow
    
        With Sheets("all").Cells
            LastFound = .Range("A1").Address(0, 0)
    
            For CountNdx = 2 To HeaderCount
                Set Found = .Find(What:=Range("A1").Value, _
                            LookAt:=xlPart, _
                            After:=Range(LastFound), _
                            SearchOrder:=xlByRows)
    
                If Found Is Nothing Then Exit For
    
                LastFound = Found.Address(0, 0)
                PageBoundaries(CountNdx - 1, 2) = Found.Offset(-1, 0).Address(0, 0) ' the last row is one row up from the next found header
                PageBoundaries(CountNdx, 1) = Found.Address(0, 0)
            Next CountNdx
    
        End With    'Sheets("all").Cells
    
        For CountNdx = 1 To HeaderCount
            Sheets("all").Range(PageBoundaries(CountNdx, 1), PageBoundaries(CountNdx, 2)).Select
            Selection.Copy
            Sheets.Add After:=Sheets(Sheets.Count)
            Selection.PasteSpecial _
                Paste:=xlPasteAll, _
                Operation:=xlNone, _
                SkipBlanks:= _
                False, Transpose:=False
    
            ActiveSheet.Name = Range("M6").Value
                
            'adjust column width of copied sheet to match sheet "all" column
    
            For Each TestCell In Range("A9:M9")
                TestCell.ColumnWidth = Sheets("All").Range(TestCell.Address).ColumnWidth
            Next TestCell
            
            'get the last row of the copied sheet
            Set LastRow = Cells(Rows.Count, 1).End(xlUp)
            
            'adjust the row height of the copied sheet to match the sheet "all row
    
            For Each TestCell In Range("A1", LastRow.Address)
                TestCell.RowHeight = Sheets("All").Range(TestCell.Address).RowHeight
            Next TestCell
    
            Range("A1").Select
            
            Sheets("All").Select
            Application.CutCopyMode = False
    
        Next CountNdx
    
        Application.ScreenUpdating = True
    End Sub

  7. #7
    Registered User
    Join Date
    11-15-2010
    Location
    Arlington, VA
    MS-Off Ver
    Excel 365
    Posts
    34

    Re: Split into multiple sheets by page breaks, preserving formatting

    Worked a treat, cheers and thanks

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Split Cell containing multiple soft breaks
    By Bernaar in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 10-09-2013, 03:13 PM
  2. Split Excel Spreadsheet Data Into New Workbooks based on page breaks
    By sarndt01 in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 09-23-2013, 02:14 AM
  3. Saving to PDF with page breaks so charts aren't split
    By wizgf19 in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 08-23-2012, 05:21 PM
  4. Replies: 1
    Last Post: 03-15-2009, 06:08 PM
  5. formatting page breaks
    By Anze in forum Excel General
    Replies: 3
    Last Post: 04-23-2005, 12:06 PM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1