I currently have the below Macro that will change the paper size and
position. How do I add a line that will make the contents in the spreadsheet
to fit on one page. However, I have about 152 pages. Help - thanks! I get
errors when adding ActiveSheet.PageSetup.PrintArea = "". Do I need to place
it in a certain order. See below for entire Macro.

mySht.PageSetup.PaperSize = xlPaperLegal
mySht.PageSetup.Orientation = xlLandscape


My current Macro: ***


Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As String
Dim myField As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column letter to use as key?")

Set myArea = Intersect(ActiveCell.CurrentRegion, Range(KeyCol &
"1").EntireColumn).Cells

Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - ActiveCell.CurrentRegion.Cells(1).Column + 1

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Befo=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
..AutoFilter Field:=myField, Criteria1:=myCell.Value
..SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
mySht.PageSetup.PaperSize = xlPaperLegal
mySht.PageSetup.Orientation = xlLandscape

..AutoFilter
End With
Resume
SheetExists:
Next myCell

For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub

I'm not sure if you're really using activesheet, but maybe...

With mySht.PageSetup
.PrintArea = ""
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

Are you sure that the activeprinter really does legal size paper???

Nikki wrote:

I currently have the below Macro that will change the paper size and
position. How do I add a line that will make the contents in the spreadsheet
to fit on one page. However, I have about 152 pages. Help - thanks! I get
errors when adding ActiveSheet.PageSetup.PrintArea = "". Do I need to place
it in a certain order. See below for entire Macro.

mySht.PageSetup.PaperSize = xlPaperLegal
mySht.PageSetup.Orientation = xlLandscape

My current Macro: ***

Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As String
Dim myField As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column letter to use as key?")

Set myArea = Intersect(ActiveCell.CurrentRegion, Range(KeyCol &
"1").EntireColumn).Cells

Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - ActiveCell.CurrentRegion.Cells(1).Column + 1

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Befo=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=myField, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
mySht.PageSetup.PaperSize = xlPaperLegal
mySht.PageSetup.Orientation = xlLandscape

.AutoFilter
End With
Resume
SheetExists:
Next myCell

For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub

--

Dave Peterson