Excel 2003: Print Area macro does not work 1

[herkiefan]

Hi all,

I have a macro that copies two worksheets and pastes them into a new workbook. Then the macro sets the print area on one of these sheets to print on one page. Then the macro saves and closes the file.

It works in the current version, however, it takes (IMHO) far too long to run. I have come up with a shorter version of the "PrintSize" macro that works on its own, but when add it to the full macro, it does not work.

The 3 code boxes are:
1. "DIR_FileSave" that works and takes freakin forever.
2. "Set_PrintSize" macro that works on its own.
3. "new_DIR_FileSave" macro that moves much quicker but does not keep the print area to one page.

Sorry for the long post.

1. DIR_FileSave

Sub DIR_FileSave()
'
' DIR_FileSave Macro
' Macro recorded 9/12/2007 by Mike Campbell
'
'
    Sheets(Array("DOR", "DIR")).Select
    Sheets("DOR").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteFormats
    Sheets("Sheet1").Name = "DOR"
    ActiveSheet.Next.Select
    Sheets("Sheet2").Name = "DIR"
    Range("A1").Select
    Sheets("DOR").Select
    Range("A1:K78").Select
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$78"
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$78"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.75)
        .RightMargin = Application.InchesToPoints(0.75)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .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 = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    ActiveWindow.DisplayGridlines = False
    Range("A1").Select
       
    fName = InputBox("Enter the file name date....   yyyymmdd", "DIR Filename")
    ChDir "R:\DOR REPORTS\2008\200803-MAR"
    ActiveWorkbook.SaveAs Filename:= _
        "R:\DOR REPORTS\2008\200803-MAR\DIR_" & fName & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    Range("A1").Select
Sheets("DOR").Select
    Range("A2").Select
End Sub

2. Set_PrintSize

Sub Set_PrintSize()
'
' Set_PrintSize Macro
' Macro recorded 3/4/2008 by Mike Campbell
'

'
    Range("A1:K81").Select
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$81"
    With ActiveSheet.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperLetter
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        
    End With
    Range("A1").Select
End Sub

3. new_DIR_FileSave

Sub new_DIR_FileSave()
'
' new_DIR_FileSave Macro
' Macro recorded 9/12/2007 by Mike Campbell
'
'
    Sheets(Array("DOR", "DIR")).Select
    Sheets("DOR").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteFormats
    Sheets("Sheet1").Name = "DOR"
    ActiveSheet.Next.Select
    Sheets("Sheet2").Name = "DIR"
    Range("A1").Select
    Sheets("DOR").Select
    Range("A1:K78").Select
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$78"
    With ActiveSheet.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperLetter
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    
    ActiveWindow.DisplayGridlines = False
    Range("A1").Select
  
    fName = InputBox("Enter the file name date....   yyyymmdd", "DIR Filename")
    ChDir "R:\DOR REPORTS\2008\200803-MAR"
    ActiveWorkbook.SaveAs Filename:= _
        "R:\DOR REPORTS\2008\200803-MAR\DIR_" & fName & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    Range("A1").Select
Sheets("DOR").Select
    Range("A2").Select
End Sub

What would cause the print area to be dropped in the condensed macro.

“Only two things are infinite, the universe and human stupidity, and I'm not sure about the former.”-Albert Einstein

 

[ck1999]

Is not you code simplified by using

Sub new_DIR_FileSave()
'
' new_DIR_FileSave Macro
' Macro recorded 9/12/2007 by Mike Campbell
'
'
    Sheets("DOR").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteFormats
    Sheets("Sheet1").Name = "DOR"
    Sheets("Sheet2").Name = "DIR"
    Sheets("DOR").Select
    With ActiveSheet.PageSetup
        .PrintArea = "$A$1:$K$78"
        .Orientation = xlPortrait
        .PaperSize = xlPaperLetter
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    ActiveWindow.DisplayGridlines = False
    Range("A2").Select
  
    fName = InputBox("Enter the file name date....   yyyymmdd", "DIR Filename")
    ChDir "R:\DOR REPORTS\2008\200803-MAR"
    ActiveWorkbook.SaveAs Filename:= _
        "R:\DOR REPORTS\2008\200803-MAR\DIR_" & fName & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
End Sub

and still get the same output.

and add

.Zoom = False
to pagesetup to fix your problem

ck1999

 

[herkiefan]

It works! You are the man. I've spent hours working on this stupid thing. It became my "white whale".

Thanks man.

Have a star!

“Only two things are infinite, the universe and human stupidity, and I'm not sure about the former.”-Albert Einstein