Makro beschleunigen
10.10.2006 00:10:01
Bernd
folgendes Makro benötigt ungefähr 10 Sekunden. Kann ich das irgendwie beschleunigen?
Gruss
Bernd
Sub daten_übertragen()
' Schaltet das Zeigen des Programmaufblaufes auf dem Bildschirm aus
Application.ScreenUpdating = False
' Beseitgt im Blatt "Meldung" alle verbundenen Zellen
Sheets("Meldung").Select
Dim Zelle As Range
For Each Zelle In ActiveSheet.UsedRange
If Zelle.MergeCells Then
Zelle.UnMerge
End If
Next Zelle
' Sortiert Liste (Gesamtliste) nach Spalte DG
Columns("A:I").Sort Key1:=Range("I2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Filtert Liste nach aktuellen Abwesenheiten.
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=7, Criteria1:="Aktuell"
' Löscht den Inhalt des Blattes "Meldung"
Sheets("Meldung").Cells.ClearContents
' Fügt oberen Teil der Meldung ein
Sheets("Legende").Range("Meldung_oberer_Teil").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Fügt Überschrift Gruppe1 ein
Sheets("Legende").Range("Überschrift_Gruppe1").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Ergänzung w/ Fehler der Deaktivierung von verschmelzten Zellen:
With Sheets("Meldung").Range("A65000").End(xlUp).Range("A1:E1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
' Filtert Liste nach Gruppe1 und fügt gefilterte Liste in Blatt "Meldung" nahtlos an
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=8, Criteria1:="Gruppe1"
Sheets("Gesamtliste").Range("A2:E30001").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Fügt Überschrift Gruppe2 ein
Sheets("Legende").Range("Überschrift_Gruppe2").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Ergänzung w/ Fehler der Deaktivierung von verschmelzten Zellen:
With Sheets("Meldung").Range("A65000").End(xlUp).Range("A1:E1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
' Filtert Liste nach Gruppe2 und fügt gefilterte Liste in Blatt "Meldung" nahtlos an
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=8, Criteria1:="Gruppe2"
Sheets("Gesamtliste").Range("A2:E30001").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Fügt Überschrift Gruppe3 ein
Sheets("Legende").Range("Überschrift_Gruppe3").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Ergänzung w/ Fehler der Deaktivierung von verschmelzten Zellen:
With Sheets("Meldung").Range("A65000").End(xlUp).Range("A1:E1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
' Filtert Liste nach Gruppe3 und fügt gefilterte Liste in Blatt "Meldung" nahtlos an
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=8, Criteria1:="Gruppe3"
Sheets("Gesamtliste").Range("A2:E30001").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Fügt Überschrift Langzeit ein
Sheets("Legende").Range("Überschrift_Langzeit").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Filtert Liste nach Langzeit und fügt gefilterte Liste in Blatt "Meldung" nahtlos an
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=8, Criteria1:="Langzeit"
Sheets("Gesamtliste").Range("A2:E30001").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Fügt unteren Teil der Meldung ein
Sheets("Legende").Range("Meldung_unterer_Teil").Copy _
Destination:=Sheets("Meldung").Range("A65000").End(xlUp).Offset(1, 0)
' Ergänzung w/ Fehler der Deaktivierung von verschmelzten Zellen:
With Sheets("Meldung").Range("A65000").End(xlUp).Range("A1:E1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
' Fügt Rahmen in der Meldung ein
Sheets("Meldung").Range("A14:E14").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
' Hebt sämtliche Filterungen auf.
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=7
Sheets("Gesamtliste").Range("A1").AutoFilter Field:=8
' Gibt Messagebox aus
MsgBox "Meldung für gewünschten Tag erstellt!"
End Sub