Code bisschen "Verschönern"
27.11.2018 11:15:05
Anna
Ich hab hier mal ein Code aufgenommen und selber verbessert und lange bneutzt. Nur die Reports werden immer träge je länger es ist. Kann man meinen Code noch irgendwie verkleinern, sodass es schneller läuft? Bin für jede Hilfe Dankbar.
Sub Report_Formatieren()
'1. Spalten werden gelöscht
Range("A:C,P:W").Delete Shift:=xlToLeft
'2. Umbennenen
Range("E1").FormulaR1C1 = "Suchbegriff"
Range("H1").FormulaR1C1 = "CTR"
Range("I1").FormulaR1C1 = "CPC"
Range("K1").FormulaR1C1 = "Umsatz"
Range("L1").FormulaR1C1 = "ACoS"
'3. In % Umwandeln
Range("H:H,L:L").NumberFormat = "0.00%"
'4. Fenster fixieren
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
'5. Farbe
Rows("1:1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
'6. Höhe der ersten Zeile
Selection.RowHeight = 27.75
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'7. Zentrieren
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'8. Fett
Selection.Font.Bold = True
'9. Autofilter
Columns("A:A").EntireColumn.AutoFit
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
Columns("I:I").EntireColumn.AutoFit
Columns("J:J").EntireColumn.AutoFit
Columns("K:K").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Selection.AutoFilter
Range("B1").Select
'10. Spalten mit Autofilter löschen
Columns("M:W").Delete Shift:=xlToLeft
End Sub