Hi Windsor

My second question was is there a simpler way of getting the page print
formated other than the way that I have it done here.

Excel is not good at this and very slow
But you can delete a lot of the lines if you want

A faster way is to use a old Excel4 macro
John Green posted this if you want to read it

PageSetup in VBA has always been a painfully slow process. If you can't avoid having
to set these parameters, you can use the Excel 4 macro function, PAGE.SETUP to carry
out most of the PageSetup operations much more quickly. The following two macros are
almost equivalent, and should give you the clues you need to start using PAGE.SETUP.
You can download a full description of all the Excel 4 macro functions from
Microsoft's web site:

Sub PS()
ActiveSheet.DisplayPageBreaks = False
With ActiveSheet.PageSetup
.LeftHeader = "My Company"
.CenterHeader = ""
.RightHeader = "&D / &T"
.LeftFooter = "Highly Confidential and Proprietary"
.CenterFooter = ""
.RightFooter = "Finance"
.LeftMargin = Application.InchesToPoints(0.54)
.RightMargin = Application.InchesToPoints(0.3)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.36)
.HeaderMargin = Application.InchesToPoints(0.22)
.FooterMargin = Application.InchesToPoints(0.17)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
' .PrintQuality = 600 ' does not work with all the printers
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End Sub

Sub PS4()
head = """&LMy Company&R&D / &T"""
foot = """&LHighly Confidential and Proprietary&RFinance"""
pLeft = 0.54
pRight = 0.3
Top = 0.4
bot = 0.36
head_margin = 0.22
foot_margin = 0.17
hdng = False
grid = False
notes = False
quality = ""
h_cntr = False
v_cntr = False
orient = 2
Draft = False
paper_size = 1
pg_num = """Auto"""
pg_order = 1
bw_cells = False
pscale = True
pSetUp = "PAGE.SETUP(" & head & "," & foot & "," & pLeft & "," & pRight & ","
pSetUp = pSetUp & Top & "," & bot & "," & hdng & "," & grid & "," & h_cntr & ","
pSetUp = pSetUp & v_cntr & "," & orient & "," & paper_size & "," & pscale & ","
pSetUp = pSetUp & pg_num & "," & pg_order & "," & bw_cells & "," & quality & ","
pSetUp = pSetUp & head_margin & "," & foot_margin & "," & notes & "," & Draft & ")"

Application.ExecuteExcel4Macro pSetUp
End Sub

John Green (Excel MVP)
Sydney
Australia



--
Regards Ron de Bruin
http://www.rondebruin.nl


"windsor" wrote in message
...

Hello Ron,

No, you gave me exactly what I needed. Thank's so much. I've been
working on this macro for quite a long time, yours is so much better,
i've incorporated your lines so that once it copies all the value it
creates a total for each coloumn that needs totalling. This is very
nice, just took me a little while to figure out which formual to use in
order to get a total to come up instead of the #REF!

My second question was is there a simpler way of getting the page print
formated other than the way that I have it done here.

Thanks.


Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim Lrow2 As Long



Set ws1 = Sheets("Sheet1") '<<< Change

'Set ws1 = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1,
0).Cells

'Set ws1 = myArea.Resize(myArea.Rows.Count - 1, 1)
'Tip : Use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

With Application
CalcMode = .Calculation
Calculation = xlCalculationManual
ScreenUpdating = False
End With

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change
this if needed)
'You see that the last two columns of the worksheet are used to
make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use
the columns)

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
Range("IU2").Value = cell.Value
Set WSNew = Sheets.Add
Printing
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & "
manually"
Err.CLEAR
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
Lrow2 = .Cells(Rows.Count, "a").End(xlUp).Row
Rows(Lrow2).Copy WSNew.Range("a" &
WSNew.UsedRange.Rows.Count + 2)
Next
Columns("IU:IV").CLEAR
End With

With Application
ScreenUpdating = True
Calculation = CalcMode
End With
End Sub

Sub Printing()
'
' Printing Macro
' Macro recorded 10/3/2005 by Dejan Lukic
'

'
With ActiveSheet.PageSetup
PrintTitleRows = "$1:$1"
PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
LeftHeader = ""
CenterHeader = ""
RightHeader = ""
LeftFooter = "&F"
CenterFooter = "&A"
RightFooter = "&P OF &N"
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 = True
CenterVertically = False
Orientation = xlLandscape
Draft = False
PaperSize = xlPaperLetter
FirstPageNumber = xlAutomatic
Order = xlDownThenOver
BlackAndWhite = False
Zoom = False
FitToPagesWide = 1
FitToPagesTall = False
PrintErrors = xlPrintErrorsDisplayed
End With
End Sub


--
windsor
------------------------------------------------------------------------
windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849
View this thread: http://www.excelforum.com/showthread...hreadid=473581