VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area

brentcole

New Member
Joined
Oct 10, 2024
Messages
1
Office Version
  1. 2019
Platform
  1. Windows
I use this macro in lots of our workbooks with macros to export single worksheets. It grabs all the source pagesetup settings, margins, etc. with the exception of the vertical page break. When I open the exported file, the vertical page break needs to be moved over right one column.
I've even tried moving the pagebreak with "ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1" but it bombs out the macro.

Is there a setting I am missing?

VBA Code:
Sub ExportSheetAsXLSX()

    Dim ws As Worksheet
    Dim newWorkbook As Workbook
    Dim exportPath As String
    Dim FileName As String
    Dim currentDate As String
    Dim fullPath As String
    Dim response As VbMsgBoxResult
    
    '''''adding these get current issue into export xlxs file name
    Dim wbBook As Workbook
    
    Dim wsSource As Worksheet
    Dim IssueType As String
    Dim cName As String
    Dim pNum As String
    Dim pTitle As String

    'Initialize the Excel objects and delete any artifacts from the last time the macro was run.
    Set wbBook = ThisWorkbook
    With wbBook
        Set wsSource = .Worksheets("Project_Data")
        On Error Resume Next
        .Names("Source").Delete
        On Error GoTo 0
    End With
    
    On Error GoTo CleanExit                         'make sure enableevents is set back to true on
    Application.EnableEvents = False                'make sure pivot table data is only updated once
    '''''adding these get current issue into export xlxs file name
    
    ' Set the worksheet to export
    Set ws = ThisWorkbook.Sheets("Line List_Prj")
    
    ' Define the export path (customize as needed)
    exportPath = ThisWorkbook.Path & "\"

    ' Get the current date formatted as YYYYMMDD
    currentDate = Format(Date, "mm-dd-yy")
    
    'get current issue type from Project_Data sheet to use in file name
    IssueType = wsSource.Range("B2").Value
    cName = wsSource.Range("D2").Value
    pNum = wsSource.Range("D4").Value
    pTitle = wsSource.Range("D3").Value
    
       
    ' Create the filename
    'example: Consolidated_BOM_For Review & Comment_LACC_ LLC _AXIALL_LOTTE JOINT VENTURE__CLIENT PRJ Lb_CLIENT PROJECT TITLE_10-10-24
    FileName = "PrjLineList_" & pNum & "_" & IssueType & "_" & cName & pTitle & "_" & currentDate & ".xlsx"
    
    'remove and replace illegal file name characters
    FileName = Replace(FileName, "~", "_")
    FileName = Replace(FileName, "!", "_")
    FileName = Replace(FileName, "@", "at")
    FileName = Replace(FileName, "#", "Lb")
    FileName = Replace(FileName, "$", "Money")
    FileName = Replace(FileName, "^", "_")
    FileName = Replace(FileName, "*", "_")
    FileName = Replace(FileName, "(", "_")
    FileName = Replace(FileName, ")", "_")
    FileName = Replace(FileName, "=", "-")
    FileName = Replace(FileName, "+", "_")
    FileName = Replace(FileName, "[", "_")
    FileName = Replace(FileName, "]", "_")
    FileName = Replace(FileName, "{", "_")
    FileName = Replace(FileName, "}", "_")
    FileName = Replace(FileName, ";", "_")
    FileName = Replace(FileName, ":", "-")
    FileName = Replace(FileName, "'", "_")
    FileName = Replace(FileName, """", "in")
    FileName = Replace(FileName, ",", "_")
    FileName = Replace(FileName, "/", "_")
    FileName = Replace(FileName, "?", "_")
    FileName = Replace(FileName, "<", "_")
    FileName = Replace(FileName, ">", "_")
    FileName = Replace(FileName, "\", "_")
    FileName = Replace(FileName, "|", "_")
    
    fullPath = exportPath & FileName

    ' Check if the file already exists
    If Dir(fullPath) <> "" Then
        response = MsgBox("The file '" & FileName & "' already exists. Do you want to overwrite it?", vbYesNo + vbExclamation, "File Exists")
        If response = vbNo Then Exit Sub
    End If

    ' Create a new workbook
    Set newWorkbook = Workbooks.Add

    ' Copy the range from columns A to AH from Line List_Prj to the new workbook
    ws.Range("A:AH").Copy
        With newWorkbook.Sheets(1).Range("A1")
            .PasteSpecial Paste:=xlPasteValues   ' Paste values only
            .PasteSpecial Paste:=xlPasteFormats  ' Paste formats
        End With
        
    'need to copy the picture also - have to switch back to Line List_Prj worksheet first
    ws.Activate
    ws.Shapes.Range(Array("Picture 2")).Select
    Selection.Copy
        With newWorkbook.Sheets(1).Range("A1")
            .PasteSpecial Paste:=xlPasteValues   ' Paste values only
            .PasteSpecial Paste:=xlPasteFormats  ' Paste formats
        End With
        
    'Need to set filename formula and paste in new sheet
    ws.Activate
    ws.Range("AH3").Copy
        With newWorkbook.Sheets(1).Range("AH3")
            .PasteSpecial Paste:=xlPasteFormulas   ' Paste formula
        End With
    
    ' Set the worksheet tab name to the current date
    newWorkbook.Sheets(1).Name = currentDate

    ' Copy headers and footers from the original worksheet
    With ws.PageSetup
        With newWorkbook.Sheets(1).PageSetup
            .CenterHeader = ws.PageSetup.CenterHeader
            .LeftHeader = ws.PageSetup.LeftHeader
            .RightHeader = ws.PageSetup.RightHeader
            .CenterFooter = ws.PageSetup.CenterFooter
            .LeftFooter = ws.PageSetup.LeftFooter
            .RightFooter = ws.PageSetup.RightFooter
            
            'Copy paper size
            .PaperSize = ws.PageSetup.PaperSize
            .Zoom = ws.PageSetup.Zoom
            .PrintQuality = ws.PageSetup.PrintQuality
            .CenterHorizontally = ws.PageSetup.CenterHorizontally
            .CenterVertically = ws.PageSetup.CenterVertically
            .Orientation = ws.PageSetup.Orientation
            
            ' Copy margin settings
            .TopMargin = ws.PageSetup.TopMargin
            .BottomMargin = ws.PageSetup.BottomMargin
            .LeftMargin = ws.PageSetup.LeftMargin
            .RightMargin = ws.PageSetup.RightMargin
            
            ' Set other margin properties
            .HeaderMargin = ws.PageSetup.HeaderMargin
            .FooterMargin = ws.PageSetup.FooterMargin
            
            ' Copy scaling settings
            .Zoom = ws.PageSetup.Zoom
            .FitToPagesWide = ws.PageSetup.FitToPagesWide
            .FitToPagesTall = ws.PageSetup.FitToPagesTall
            '''.FitToHeight = ws.PageSetup.FitToHeight
            '''.FitToWidth = ws.PageSetup.FitToWidth
            
            ' Copy rows to repeat
            .PrintTitleRows = ws.PageSetup.PrintTitleRows
            '''.RowsToRepeatAtTop = ws.PageSetup.RowsToRepeatAtTop
            '''On Error Resume Next
            '''.RowsToRepeatAtTop = .RowsToRepeatAtTop
            '''On Error GoTo 0
            
            ' Copy print area
            .printArea = ws.PageSetup.printArea
            .FitToPagesWide = ws.PageSetup.FitToPagesWide
            .FitToPagesTall = ws.PageSetup.FitToPagesTall
        End With
        
    End With
    
    ' Set the row height to match the original
    newWorkbook.Sheets(1).Rows(1).RowHeight = ws.Rows(1).RowHeight
    newWorkbook.Sheets(1).Rows(2).RowHeight = ws.Rows(2).RowHeight
    newWorkbook.Sheets(1).Rows(3).RowHeight = ws.Rows(3).RowHeight
    
    ' Save the new workbook
    newWorkbook.SaveAs FileName:=fullPath, FileFormat:=xlOpenXMLWorkbook
    newWorkbook.Close SaveChanges:=False

    ' Inform the user
    MsgBox "Export completed! The file is saved as: " & FileName, vbInformation, "Export Successful"

CleanExit:
    ActiveWorkbook.Save
    Application.EnableEvents = True
    Application.Cursor = xlDefault
    'if screenupdating was enabled when readjobinfo started, reenable it
    If Application.ScreenUpdating = True Then Application.ScreenUpdating = True
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True
    On Error GoTo 0            'return to standard error handling
    
End Sub
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Forum statistics

Threads
1,224,567
Messages
6,179,569
Members
452,926
Latest member
rows and columns

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top