Tablo şekillendirme ve yazdırma makrosu

[sscey]

Hergün internetten sıklıkla indirdiğim ve şekillendirip yazdırdığım bir tablom var. Bu tabloyu şekillendirme ve yazdırma ile ilgili bir macro oluşturdum, şekillendir ve yazdır şeklindede bir butonum var ona tıkladığmdada başarıyla da çalışıyor. Macroyu, "macro oluştur" ile yaptığımdan çok uzun ve birazda yavaş çalışıyor, sizden isteğim bu macroyu kısaltabilirmiyiz? Dosya ektedir, yardımcı olursanız sevinirim.[vb:1:049a5f9372]Sub Sevk()
'
' Sevk Makro
' Makro dore tarafından 04.12.2005 tarihinde kaydedildi.
'
' Klavye Kısayolu: Ctrl+s
'
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = _
"BAÞLIK1" & Chr(10) & "BAÞLIK2" & Chr(10) & "BAÞLIK4" & Chr(10) & "BAÞLIK5" & Chr(10) & "BAÞLIK7"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "&D &T" & Chr(10) & "ALTBAÞLIK 1"
.RightFooter = "Tel: 499 99 99"
.LeftMargin = Application.InchesToPoints(0.748031496062992)
.RightMargin = Application.InchesToPoints(0.748031496062992)
.TopMargin = Application.InchesToPoints(0.84251968503937)
.BottomMargin = Application.InchesToPoints(0.584251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -2
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA5
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 75
.PrintErrors = xlPrintErrorsDisplayed
End With
Range("A313").Select
With Selection.Font
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
Range("A10").Select
Columns("A:A").ColumnWidth = 27.14
Rows("10:10").RowHeight = 34.5

Rows("12:12").RowHeight = 32.25
Rows("13:13").RowHeight = 53.25
Range("A413").Select
Selection.Font.Bold = False
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B10:B12").Select
Selection.Font.Bold = True
Range("D1012").Select
Selection.Font.Bold = True
Range("B10:B12").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D1012").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A313").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 1
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub


[/vb:1:049a5f9372]

 

[sscey]

Yardım isteğime cevep verecek kimse yok mu bu forumda? Olumsuz da olsa lütfen birileri cevap yazabilir mi? Ã?zellikle adminlerden cevap bekliyorum....