Makro extrem langsam
26.09.2019 15:23:06
MarKo
Besteht die Möglichkeit es zu beschleunigen ? Oder habe ich etwas falsch gemacht ?
Danke
Option Explicit
' Definition der Variablen für das Makro
Dim DSheet As Worksheet
Dim PSheet As Worksheet
Dim GSheet As Worksheet
Dim PRange As Range
Dim LastRow As Long
Dim LastColumn As Long
Dim KillSpalten As Range
Dim rngTmp As Range
Dim ArBegriffe() As Variant
Dim lz As CellFormat
Dim var As Variant
Dim introw As Integer
Dim x As Long
Dim i As Long
Dim lstrDatei As String
Dim d As Variant
Dim iWert As Integer
Dim z As Integer
Dim ende, iRow As Long
Dim wks As Worksheet
Dim lngLetzte As Long, lngI As Long
Dim rng As Range
Sub DatenLaden()
'Display bestätigungen ausschalten
Application.DisplayAlerts = False
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Öffne Datei Daten
Workbooks.OpenText Filename:="C:\Users\OliS\Desktop\Daten.xls", _
Origin:=1250, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
' Löscht leere Spalten
Columns("S:S").Select
Selection.Delete Shift:=xlToLeft
Columns("R:R").Select
Selection.Delete Shift:=xlToLeft
Columns("P:P").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Selection.Delete Shift:=xlToLeft
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
Columns("K:K").Select
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("I:I").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
'Löscht Zeilen 1-5
Rows("1:5").Select
Selection.Delete Shift:=xlUp
'Löschen der Zeile, wenn Zelle in Spalte A leer ist
Dim introw As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For introw = intLastRow To 1 Step -1
If Application.CountA(Rows(introw)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next introw
For introw = intLastRow To 1 Step -1
If IsEmpty(Cells(introw, 1)) Then
Rows(introw).Delete
End If
Next introw
'Spalten neu benennen
Range("A1").Select
ActiveCell.FormulaR1C1 = "Daten"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Auftragsnummer"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Datum"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Stückzahl"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Termin"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Einteilung"
'Filter setzen größer als 90000000 Spalte C und löschen
With ActiveSheet
.Range("A1").AutoFilter Field:=3, Criteria1:= _
"100000000"
.Rows(1).Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).Delete
.Rows(1).Hidden = False
.AutoFilterMode = False
End With
'Filter setzen Summe Spalte A und löschen
With ActiveSheet
.Range("A1").AutoFilter Field:=1, Criteria1:="Summe"
.Rows(1).Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).Delete
.Rows(1).Hidden = False
.AutoFilterMode = False
End With
'Filter setzen Woche Spalte A und löschen
With ActiveSheet
.Range("A1").AutoFilter Field:=1, Criteria1:="Woche"
.Rows(1).Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).Delete
.Rows(1).Hidden = False
.AutoFilterMode = False
End With
'Filter setzen A06 Spalte F und löschen
With ActiveSheet
.Range("A1").AutoFilter Field:=6, Criteria1:="A06"
.Rows(1).Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).Delete
.Rows(1).Hidden = False
.AutoFilterMode = False
End With
'Filter absteigent sotieren
With ActiveSheet
.Range("A1").AutoFilter Field:=6
Range("F" & Range("F65536").End(xlUp).Row).Sort _
Key1:=Range("F2"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.AutoFilterMode = False
End With
'Duplicate entfernen
ActiveSheet.Range("$A$1:$F$655326").RemoveDuplicates Columns:=2, Header:=xlYes
'Bereich zum kopieren makieren
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
'Bereich kopieren
Selection.Copy
'Wechsel zu Datei Auswertung
Windows("Auswertung.xlsm").Activate
Sheets("DatenNeu").Select
'Erste Freie Zeile in A finden
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
'Einfügen
ActiveSheet.Paste
'Duplicate entfernen
For i = Range("B65536").End(xlUp).Row To 2 Step -1
If Application.WorksheetFunction.CountIf(Range("B:B"), Cells(i, 2)) > 1 Then Rows(i).Delete
Next i
'Datei Daten Wachs aktivieren
Windows("Daten.xls").Activate
'Mackierter Bereich aufheben
Application.CutCopyMode = False
'Datei schließen ohne zu Fragen
Workbooks("Daten.xls").Close savechanges:=False
'Gehe für nächste Abfrage auf A1
Sheets("DatenNeu").Select
Range("A1").Select
'Gehe zu Blatt Auswertung
Sheets("Auswertung").Select
'Schreibe Datum der Aktualisierung
Sheets("Auswertung").Range("B3").Value = Date & "/" & Time
'Tabellenblatt wechseln
Sheets("Auswertung").Select
'Excelbildschrim ausblenden
Application.Visible = False
'Anzeige MsgBox
MsgBox "Aktualisierung erfolgreich"
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub