N
Nikki
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(Before:=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
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(Before:=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