Makro abspecken
04.03.2008 16:53:21
Alex
Meine Frage:
Ist das folgende Makro noch kürzer zugestalten ?
Hat jemand eine Idee ob das geht und wenn ja - Wie ?
Einstweilen herzlichen Dank an alle, die sich für mich bemühen.
MfG
Alex
Sub Makro1()
Application.ScreenUpdating = False
Rem Füllfarbe löschen
Range("C2:D2,E2,C7,D7,E7,C31:D31,E31").Select
Selection.Interior.ColorIndex = xlNone
Rem Schriftfarbe löschen
Range("E2,E7,E31").Select
Selection.Font.ColorIndex = 0
Rem Rahmen löschen
Range("C7,D7,E7,C31:D31,E31").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$E$35"
.LeftMargin = Application.CentimetersToPoints(2)
.RightMargin = Application.CentimetersToPoints(0)
.TopMargin = Application.CentimetersToPoints(1.5)
.BottomMargin = Application.CentimetersToPoints(0)
.HeaderMargin = Application.CentimetersToPoints(0)
.FooterMargin = Application.CentimetersToPoints(0)
.PaperSize = xlPaperA5
.Orientation = xlPortrait
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Rem Füllfarbe setzen
Range("C2:D2,E2,D7,C7,E7,C31:D31,E31").Select
With Selection.Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
Rem Schriftfarbe setzen
Range("E2,E7,E31").Select
Selection.Font.ColorIndex = 3
Rem Rahmen setzen
Range("C7,D7,E7,C31:D31,E31").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1").Activate
Application.ScreenUpdating = True
End Sub