Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
808to812
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
808to812
808to812
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro beschleunigen

Makro beschleunigen
10.10.2006 00:10:01
Bernd
Hallo,
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

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro beschleunigen
10.10.2006 00:28:43
Ali
Hi,
Option Explicit

Sub til()
Dim appCalculation As Long
appCalculation = Application.Calculation
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorExit
'dein Code
ErrorExit:
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = appCalculation
End With
End Sub

mfg Ali
Fehler, siehe Korrektur anderes posting
10.10.2006 00:30:39
Ali
a
AW: Makro beschleunigen
10.10.2006 11:54:40
Bernd
Danke Ali,
das probiere ich gleich mal aus.
Könntest du deinen Code vielleicht dennoch nochmal etwas erläutern, damit ich ihn zumindest verstehe.

Sub Ali()
Dim appCalculation As Long
appCalculation = Application.Calculation
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorExit
End Sub

Vor allem: was ist EnableEvents?
Gruss
bernd
Anzeige
AW: Makro beschleunigen
10.10.2006 12:08:21
Bernd
... erledigt.
Ich hab jetzt ein viel schlimmeres Problem. Siehe neuen Thread
AW: Makro beschleunigen
10.10.2006 00:29:31
Ali
Hi,
Option Explicit

Sub til()
Dim appCalculation As Long
appCalculation = Application.Calculation
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorExit
'dein Code
ErrorExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = appCalculation
End With
End Sub

mfg Ali

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige