Makro tunen!
01.06.2005 11:20:51
Sammy
Leider beinhaltet meine Praktikantenarbeit das erstelln von Projektionen. Diese werden von unserem System aber nur halbfertig ausgeliefert und ich darf sie dann mit Formatierungen und Summenbildungen aufwerten.
Dieses stellt ja an sich kein Problem, leider häufen sich diese aber und es macht kein Spaß. Nun bin ich auf die Idee gekommen das man dafür doch ein Makro benutzen könnte.
Mein Problem: Alle Projektionen kommen gleich bei mir an, nur die länge ist unterschiedlich. Nun habe ich folgendes Makro gemacht:
<pre>
Sub Projektion()
'
' Projektion Makro
' Makro am 01.06.2005 von sammyabushab aufgezeichnet
'
' Tastenkombination: Strg+q
'
Columns("E:Y").Select
Selection.Delete Shift:=xlToLeft
Range("D1").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("E2").Select
With Selection.Interior
.ColorIndex = 47
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveCell.FormulaR1C1 = "Costs"
With ActiveCell.Characters(Start:=1, Length:=5).Font
.Name = "Verdana"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = 2
End With
Range("E3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]"
Range("E4").Select
ActiveWindow.ScrollColumn = 1
Range("E3").Select
Selection.AutoFill Destination:=Range("E3:E245"), Type:=xlFillDefault
Range("E3:E245").Select
Range("A246").Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveCell.FormulaR1C1 = "TOTAL"
With ActiveCell.Characters(Start:=1, Length:=5).Font
.Name = "Verdana"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Range("B246").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-243]C:R[-1]C)"
Range("C246").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-243]C:R[-1]C)"
Range("E246").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-243]C:R[-1]C)"
Range("D246").Select
ActiveCell.FormulaR1C1 = "=RC[1]/RC[-1]"
Range("A246:E246").Select
Range("E246").Activate
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.Bold = True
Range("A3:E245").Select
Range("E245").Activate
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
ActiveWindow.ScrollRow = 229
ActiveWindow.ScrollRow = 228
ActiveWindow.ScrollRow = 227
ActiveWindow.ScrollRow = 226
ActiveWindow.ScrollRow = 225
ActiveWindow.ScrollRow = 223
ActiveWindow.ScrollRow = 222
ActiveWindow.ScrollRow = 220
ActiveWindow.ScrollRow = 218
ActiveWindow.ScrollRow = 216
ActiveWindow.ScrollRow = 213
ActiveWindow.ScrollRow = 211
ActiveWindow.ScrollRow = 208
ActiveWindow.ScrollRow = 206
ActiveWindow.ScrollRow = 203
ActiveWindow.ScrollRow = 199
ActiveWindow.ScrollRow = 197
ActiveWindow.ScrollRow = 194
ActiveWindow.ScrollRow = 185
ActiveWindow.ScrollRow = 183
ActiveWindow.ScrollRow = 175
ActiveWindow.ScrollRow = 166
ActiveWindow.ScrollRow = 163
ActiveWindow.ScrollRow = 156
ActiveWindow.ScrollRow = 148
ActiveWindow.ScrollRow = 139
ActiveWindow.ScrollRow = 132
ActiveWindow.ScrollRow = 125
ActiveWindow.ScrollRow = 118
ActiveWindow.ScrollRow = 110
ActiveWindow.ScrollRow = 103
ActiveWindow.ScrollRow = 95
ActiveWindow.ScrollRow = 92
ActiveWindow.ScrollRow = 84
ActiveWindow.ScrollRow = 77
ActiveWindow.ScrollRow = 74
ActiveWindow.ScrollRow = 67
ActiveWindow.ScrollRow = 60
ActiveWindow.ScrollRow = 57
ActiveWindow.ScrollRow = 50
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 45
ActiveWindow.ScrollRow = 42
ActiveWindow.ScrollRow = 40
ActiveWindow.ScrollRow = 37
ActiveWindow.ScrollRow = 35
ActiveWindow.ScrollRow = 34
ActiveWindow.ScrollRow = 32
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollRow = 28
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 25
ActiveWindow.ScrollRow = 23
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 21
ActiveWindow.ScrollRow = 20
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 17
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Range("A2:E245").Select
Range("E245").Activate
Selection.Sort Key1:=Range("C3"), Order1:=xlDescending, Key2:=Range("B3") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
ActiveWindow.ScrollRow = 229
ActiveWindow.ScrollRow = 228
ActiveWindow.ScrollRow = 227
ActiveWindow.ScrollRow = 226
ActiveWindow.ScrollRow = 225
ActiveWindow.ScrollRow = 224
ActiveWindow.ScrollRow = 223
ActiveWindow.ScrollRow = 222
ActiveWindow.ScrollRow = 221
ActiveWindow.ScrollRow = 219
ActiveWindow.ScrollRow = 218
ActiveWindow.ScrollRow = 215
ActiveWindow.ScrollRow = 214
ActiveWindow.ScrollRow = 212
ActiveWindow.ScrollRow = 210
ActiveWindow.ScrollRow = 208
ActiveWindow.ScrollRow = 206
ActiveWindow.ScrollRow = 204
ActiveWindow.ScrollRow = 202
ActiveWindow.ScrollRow = 199
ActiveWindow.ScrollRow = 197
ActiveWindow.ScrollRow = 194
ActiveWindow.ScrollRow = 187
ActiveWindow.ScrollRow = 184
ActiveWindow.ScrollRow = 177
ActiveWindow.ScrollRow = 174
ActiveWindow.ScrollRow = 167
ActiveWindow.ScrollRow = 160
ActiveWindow.ScrollRow = 156
ActiveWindow.ScrollRow = 149
ActiveWindow.ScrollRow = 146
ActiveWindow.ScrollRow = 143
ActiveWindow.ScrollRow = 140
ActiveWindow.ScrollRow = 133
ActiveWindow.ScrollRow = 125
ActiveWindow.ScrollRow = 118
ActiveWindow.ScrollRow = 110
ActiveWindow.ScrollRow = 103
ActiveWindow.ScrollRow = 94
ActiveWindow.ScrollRow = 87
ActiveWindow.ScrollRow = 79
ActiveWindow.ScrollRow = 70
ActiveWindow.ScrollRow = 62
ActiveWindow.ScrollRow = 54
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 38
ActiveWindow.ScrollRow = 35
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 21
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Cells.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SmallScroll Down:=-9
Columns("D:E").Select
Selection.NumberFormat = "#,##0.00 $"
Columns("B:C").Select
Selection.Style = "Comma"
Selection.NumberFormat = _
"_-* #,##0.0 __-;-* #,##0.0 __-;_-* ""-""? __-;_-@_-"
Selection.NumberFormat = "_-* #,##0 __-;-* #,##0 __-;_-* ""-""? __-;_-@_-"
Range("D13").Select
ActiveWindow.SmallScroll Down:=150
ActiveWindow.ScrollRow = 150
ActiveWindow.ScrollRow = 149
ActiveWindow.ScrollRow = 148
ActiveWindow.ScrollRow = 147
ActiveWindow.ScrollRow = 146
ActiveWindow.ScrollRow = 145
ActiveWindow.ScrollRow = 143
ActiveWindow.ScrollRow = 141
ActiveWindow.ScrollRow = 139
ActiveWindow.ScrollRow = 137
ActiveWindow.ScrollRow = 135
ActiveWindow.ScrollRow = 133
ActiveWindow.ScrollRow = 130
ActiveWindow.ScrollRow = 128
ActiveWindow.ScrollRow = 121
ActiveWindow.ScrollRow = 118
ActiveWindow.ScrollRow = 115
ActiveWindow.ScrollRow = 112
ActiveWindow.ScrollRow = 104
ActiveWindow.ScrollRow = 97
ActiveWindow.ScrollRow = 91
ActiveWindow.ScrollRow = 88
ActiveWindow.ScrollRow = 85
ActiveWindow.ScrollRow = 82
ActiveWindow.ScrollRow = 81
ActiveWindow.ScrollRow = 78
ActiveWindow.ScrollRow = 75
ActiveWindow.ScrollRow = 73
ActiveWindow.ScrollRow = 70
ActiveWindow.ScrollRow = 68
ActiveWindow.ScrollRow = 66
ActiveWindow.ScrollRow = 63
ActiveWindow.ScrollRow = 62
ActiveWindow.ScrollRow = 59
ActiveWindow.ScrollRow = 57
ActiveWindow.ScrollRow = 55
ActiveWindow.ScrollRow = 53
ActiveWindow.ScrollRow = 51
ActiveWindow.ScrollRow = 49
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 46
ActiveWindow.ScrollRow = 44
ActiveWindow.ScrollRow = 42
ActiveWindow.ScrollRow = 41
ActiveWindow.ScrollRow = 39
ActiveWindow.ScrollRow = 37
ActiveWindow.ScrollRow = 35
ActiveWindow.ScrollRow = 33
ActiveWindow.ScrollRow = 32
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollRow = 29
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 26
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 23
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 21
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 17
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Range("E2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B8").Select
End Sub</pre>
Besteht die Möglichkeit die länge variabel zu gestalten, so dass er von alleine erkennt wann die Projektion aufhört... und was er alles formatieren und berechnen muss?
Habe eine Datei angehängt mit vorher nachher, bei Fragen stehe ich euch natürlich gerne zur Verfügung.
https://www.herber.de/bbs/user/23469.xls
Viele Grüße
Sammy