• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

paste sheet from template and remain page format and print area

W

Wim Geuens

Member
Hello,

I found a vba code that allows me to add new sheets tot a workbook.
The only thing that it does not do is keeping the page format (print area). The original sheet is printed on 2 pages, but when I run the macro it print on more then 2 pages because it doesn't hold on to the print area.

Can someone help me to adjust the code?

thanks!
Code: 
Sub AddSheetz()
'First, jump through the validation hoops (need Variant to error-check)
Dim AddSheetQuestion As Variant
'Define the application input box question
showAddSheetQuestion:
AddSheetQuestion = Application.InputBox _
("Please enter the name of the sheet you want to add," & vbCrLf & _
"or click the Cancel button to cancel the addition:", _
"What sheet do you want to add?")
'Cancel or the X was clicked
If AddSheetQuestion = False Then
MsgBox "You clicked the Cancel button." & vbCrLf & _
"No new sheet will be added.", 64, "Cancel was clicked."
Exit Sub
'OK was clicked without anything being entered
ElseIf AddSheetQuestion = "" Then
MsgBox "You clicked OK but entered nothing." & vbCrLf & vbCrLf & _
"Please type in a valid sheet name." & vbCrLf & _
"Otherwise, you must click Cancel to exit." & vbCrLf & vbCrLf & _
"Click OK and let's try again.", 48, "Hmmm...that didn't make sense..."
GoTo showAddSheetQuestion
End If
'See if a worksheet exists that is named as the new name being attempted to add.
If SheetExists(CStr(AddSheetQuestion)) Then
MsgBox "A worksheet already exists that is named " & AddSheetQuestion & "." _
& vbCrLf & vbCrLf & _
"Please click OK, verify the name you really" & vbCrLf & _
"want to add, and try again." & vbCrLf & vbCrLf & "Sheet addition cancelled.", _
48, "Sorry, that name already taken."
GoTo showAddSheetQuestion
End If
'Error trap for naming syntax error
On Error GoTo ErrorHandler1
'Here's the actual sheet addition code
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'Add and name the new sheet
Worksheets.Add
With ActiveSheet
.Name = AddSheetQuestion
.Move After:=Worksheets(Worksheets.Count)
End With
 
'Make the Template sheet visible, and copy it
Worksheets("Sheet1").Cells.Copy
'Re-activate the new worksheet, and paste
'Worksheets(AddSheetQuestion).PasteSpecial
With Worksheets("AddSheetQuestion")
.Cells.PasteSpecial xlValues
.Cells.PasteSpecial xlFormats
End With
 
With Application
.CutCopyMode = False
.GoTo Range("A1"), True
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
'Inform the user the macro is completed
MsgBox "The new sheet name ''" & AddSheetQuestion & "'' has been added.", _
64, "Sheet addition successful."
Exit Sub
'If a sheet naming syntax occurs:
ErrorHandler1:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
MsgBox "You entered a character that cannot be part of a sheet name." & vbNewLine & _
"Sheet names cannot contain the following:-" & vbNewLine & _
"'':'' , ''/'' , ''\'' , ''?'' , ''*'' , ''['' , or '']''.", _
16, "Name syntax error."
On Error GoTo 0
GoTo showAddSheetQuestion
End Sub
Function SheetExists(strWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(strWSName)
If Not ws Is Nothing Then SheetExists = True
'Boolean function assumed to be False unless set to True
End Function
 
I think the middle section just needs to get changed. Check this out:
Code: 
Sub AddSheetz()
'First, jump through the validation hoops (need Variant to error-check)
Dim AddSheetQuestion As Variant
'Define the application input box question
showAddSheetQuestion:
AddSheetQuestion = Application.InputBox _
("Please enter the name of the sheet you want to add," & vbCrLf & _
"or click the Cancel button to cancel the addition:", _
"What sheet do you want to add?")
'Cancel or the X was clicked
If AddSheetQuestion = False Then
MsgBox "You clicked the Cancel button." & vbCrLf & _
"No new sheet will be added.", 64, "Cancel was clicked."
Exit Sub
'OK was clicked without anything being entered
ElseIf AddSheetQuestion = "" Then
MsgBox "You clicked OK but entered nothing." & vbCrLf & vbCrLf & _
"Please type in a valid sheet name." & vbCrLf & _
"Otherwise, you must click Cancel to exit." & vbCrLf & vbCrLf & _
"Click OK and let's try again.", 48, "Hmmm...that didn't make sense..."
GoTo showAddSheetQuestion
End If
'See if a worksheet exists that is named as the new name being attempted to add.
If SheetExists(CStr(AddSheetQuestion)) Then
MsgBox "A worksheet already exists that is named " & AddSheetQuestion & "." _
& vbCrLf & vbCrLf & _
"Please click OK, verify the name you really" & vbCrLf & _
"want to add, and try again." & vbCrLf & vbCrLf & "Sheet addition cancelled.", _
48, "Sorry, that name already taken."
GoTo showAddSheetQuestion
End If
'Error trap for naming syntax error
On Error GoTo ErrorHandler1
 
 
'Here's the actual sheet addition code
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
 
'Instead of creating a new sheet, naming it, and then copying from Template sheet
'it will be more efficient to just copy the Template sheet directly
'Copy the Template sheet and rename it
Worksheets("Sheet1").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = AddSheetQuestion
 
With Application
.GoTo Range("A1"), True
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
'Inform the user the macro is completed
MsgBox "The new sheet name ''" & AddSheetQuestion & "'' has been added.", _
64, "Sheet addition successful."
Exit Sub
'If a sheet naming syntax occurs:
ErrorHandler1:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
MsgBox "You entered a character that cannot be part of a sheet name." & vbNewLine & _
"Sheet names cannot contain the following:-" & vbNewLine & _
"'':'' , ''/'' , ''\'' , ''?'' , ''*'' , ''['' , or '']''.", _
16, "Name syntax error."
On Error GoTo 0
GoTo showAddSheetQuestion
End Sub
Function SheetExists(strWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(strWSName)
If Not ws Is Nothing Then SheetExists = True
'Boolean function assumed to be False unless set to True
End Function
 
Hi,

it still doesn't copy the print range :-(

Sheet 1 is printed over 2 pages, when i run the macro, the new sheets is printed over 8 pages...

Anyone else has an idea?

thanks!
 
Hi, Wim Geuens!

If you follow these steps:
- create a new workbook
- start macro recorder
- go to Page Layout tab, Page Setup group, click on the bottom right little arrow

You'll be prompted with the Page Setup window. If you:
- go to Page tab and set proper values
- go to Margins tab and set proper values
- go to Header & Footer tab
- click on Customize Header and set proper values
- click on Customize Footer and set proper values
- go to Worksheet (last) tab and set proper values
- Accept
- stop macro recorder

Then if you_
- go to the VBA editor (Alt-F11)
- open the modules node
- double click on the last generic module

You'll find all the options that can be setup for the current worksheet. It'd be something like this:
Code: 
Option Explicit

Sub Macro1()
'
' Macro1 Macro
'

'
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = "$A:$B"
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = "$A$1:$J$30"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = "a"
        .CenterHeader = "b"
        .RightHeader = "c"
        .LeftFooter = "d"
        .CenterFooter = "e"
        .RightFooter = "f"
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.748031496062992)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub

From there you can extract only the desired items that you want to include in your code (no need to use all) and adjust their values to fit your requirements.

Hope it helps.

Regards!
 
Why do you not have an already formatted sheet like a template that you can copy/move rename the whole sheet etc using your above code.
 
Lymm said:
Why do you not have an already formatted sheet like a template that you can copy/move rename the whole sheet etc using your above code.
Click to expand...
This is what I thought the OP was doing originally.

@OP
Whatever your template sheet is, that is the one you will need to setup properly with page settings, if you go with my code. The code I posted simply copies the template sheet and renames it.
 
I thought they were adding a new, blank sheet which did not have any formatting or set print area.
 
You must log in or register to reply here.
Back
Top