27.01.2018, 13:34
Hallo
weil ich bei einem Testlauf gemerkt habe das der Code mit vielen daten relativ langsam ist habe ich ihn noch einmal auf Spaltenweise kopieren umgeschrieben. Zur Kontrolle eine MsgBox eingebaut die die benötigte Zeit anzeigt. Ich denke so ist der Code wesentlich schneller und effizienter.
Wie man das Makro anders starten soll als über einen CommandButton bin ich im Augenblick überfragt?? Würde mich freuen wenn der neue Code schneller laueft. Aber bitte noch prüfen ob alle Spalten korrekt kopiert werden? Kein Verdreher drin ist! Sonst bitte selbst aendern.
mfg Gast 123
weil ich bei einem Testlauf gemerkt habe das der Code mit vielen daten relativ langsam ist habe ich ihn noch einmal auf Spaltenweise kopieren umgeschrieben. Zur Kontrolle eine MsgBox eingebaut die die benötigte Zeit anzeigt. Ich denke so ist der Code wesentlich schneller und effizienter.
Wie man das Makro anders starten soll als über einen CommandButton bin ich im Augenblick überfragt?? Würde mich freuen wenn der neue Code schneller laueft. Aber bitte noch prüfen ob alle Spalten korrekt kopiert werden? Kein Verdreher drin ist! Sonst bitte selbst aendern.
mfg Gast 123
Code:
'Thread von Wexel will Code testen lassen
Option Explicit
Const SortAnfAdr = "C8" 'Sortieren Anfang-Adresse
Const SortEndSpa = "BI" 'Sortieren End-Spalte "BI"
Const SAdr1 = "D8" '1.Adresse Sortierspalte (Option)
Sub Alle_auflisten_sortieren_5()
'Liste Reparatur und Wartungsliste auf und selktiere nach Tag-Nr
Dim Zeit
Zeit = Time
Worksheets("All time In").Range("A8:BI500").ClearContents
Call Reparaturen_auflisten_SpWeise
Call Wartung_auflisten_SpWeise
Call Ungültige_Daten_löschen
Call AllTime_Daten_sortieren
Application.ScreenUpdating = True
MsgBox Second(Zeit - Time)
End Sub
Sub Reparaturen_auflisten_SpWeise()
'Überschreibe Wartungsliste nach nach All time In
Dim a As Long, lz As Long, ATI As Worksheet
Set ATI = Worksheets("All time In")
Application.ScreenUpdating = False
With Worksheets("Reparaturliste")
'LastZelle in All time In in Spalte A ermitteln +1
lz = .Cells(Rows.Count, 1).End(xlUp).Row - 5
a = ATI.Cells(Rows.Count, 3).End(xlUp).Row + 1
If a < 8 Then a = 8
'Ziel All time In = aus Liste Reparaturarbeiten
.Cells(6, 1).Resize(lz, 1).Copy
ATI.Cells(a, 3).PasteSpecial xlPasteValues
.Cells(6, 2).Resize(lz, 1).Copy
ATI.Cells(a, 4).PasteSpecial xlPasteValues
.Cells(6, 3).Resize(lz, 1).Copy
ATI.Cells(a, 36).PasteSpecial xlPasteValues
.Cells(6, 4).Resize(lz, 1).Copy
ATI.Cells(a, 37).PasteSpecial xlPasteValues
.Cells(6, 5).Resize(lz, 1).Copy
ATI.Cells(a, 38).PasteSpecial xlPasteValues
.Cells(6, 6).Resize(lz, 1).Copy
ATI.Cells(a, 41).PasteSpecial xlPasteValues
.Cells(6, 7).Resize(lz, 1).Copy
ATI.Cells(a, 39).PasteSpecial xlPasteValues
.Cells(6, 8).Resize(lz, 1).Copy
ATI.Cells(a, 40).PasteSpecial xlPasteValues
.Cells(6, 9).Resize(lz, 1).Copy
ATI.Cells(a, 56).PasteSpecial xlPasteValues
.Cells(6, 10).Resize(lz, 1).Copy
ATI.Cells(a, 9).PasteSpecial xlPasteValues
.Cells(6, 11).Resize(lz, 1).Copy
ATI.Cells(a, 10).PasteSpecial xlPasteValues
.Cells(6, 15).Resize(lz, 1).Copy
ATI.Cells(a, 5).PasteSpecial xlPasteValues
'Datum Zeile R mitkopieren zum Löschen ungültiger daten
.Cells(6, 18).Resize(lz, 1).Copy
ATI.Cells(a, "BJ").PasteSpecial xlPasteAll
End With
'Lösche Daten Zwischenablage
Application.CutCopyMode = False
End Sub
Sub Wartung_auflisten_SpWeise()
'Überschreibe Wartungsliste nach aktualisieren nach All time in
Dim a As Long, lz As Long, ATI As Worksheet
Set ATI = Worksheets("All time In")
Application.ScreenUpdating = False
With Worksheets("Wartungsliste")
'LastZelle in All time In in Spalte A ermitteln +1
lz = .Cells(Rows.Count, 1).End(xlUp).Row - 5
a = ATI.Cells(Rows.Count, 3).End(xlUp).Row + 1
If a < 8 Then a = 8
'Ziel All time In = aus Liste Reparaturarbeiten
.Cells(6, 1).Resize(lz, 1).Copy
ATI.Cells(a, 3).PasteSpecial xlPasteValues
.Cells(6, 2).Resize(lz, 1).Copy
ATI.Cells(a, 4).PasteSpecial xlPasteValues
.Cells(6, 3).Resize(lz, 1).Copy
ATI.Cells(a, 5).PasteSpecial xlPasteValues
.Cells(6, 4).Resize(lz, 1).Copy
ATI.Cells(a, 6).PasteSpecial xlPasteValues
.Cells(6, 8).Resize(lz, 1).Copy
ATI.Cells(a, 36).PasteSpecial xlPasteValues
.Cells(6, 9).Resize(lz, 1).Copy
ATI.Cells(a, 37).PasteSpecial xlPasteValues
.Cells(6, 10).Resize(lz, 1).Copy
ATI.Cells(a, 38).PasteSpecial xlPasteValues
.Cells(6, 11).Resize(lz, 1).Copy
ATI.Cells(a, 41).PasteSpecial xlPasteValues
.Cells(6, 12).Resize(lz, 1).Copy
ATI.Cells(a, 39).PasteSpecial xlPasteValues
.Cells(6, 13).Resize(lz, 1).Copy
ATI.Cells(a, 40).PasteSpecial xlPasteValues
.Cells(6, 14).Resize(lz, 1).Copy
ATI.Cells(a, 56).PasteSpecial xlPasteValues
.Cells(6, 15).Resize(lz, 1).Copy
ATI.Cells(a, 9).PasteSpecial xlPasteValues
.Cells(6, 16).Resize(lz, 1).Copy
ATI.Cells(a, 10).PasteSpecial xlPasteValues
'Datum Zeile R mitkopieren zum Löschen ungültiger daten
.Cells(6, 7).Resize(lz, 1).Copy
ATI.Cells(a, "BJ").PasteSpecial xlPasteAll
End With
'Lösche Daten Zwischenablage
Application.CutCopyMode = False
End Sub
Sub Ungültige_Daten_löschen()
'Überschreibe Wartungsliste nach nach All time In
Dim j As Long, lz As Long, ATI As Worksheet
Worksheets("All time In").Select
Application.ScreenUpdating = False
With Worksheets("All time In")
'LastZelle in All time In in Spalte A ermitteln +1
lz = .Cells(Rows.Count, 3).End(xlUp).Row
For j = 8 To lz
If .Cells(j, "BJ") <> .Range("G1").Value Then
Cells(j, 2).Resize(1, 61).ClearContents
Else 'Datum wieder löschen
Cells(j, "BJ").ClearContents
End If
Next j
End With
End Sub
Sub AllTime_Daten_sortieren() 'Sortier Routine in "All time In"
Dim SortEndAdr As String, lzA As Long
With Worksheets("All time In")
'LastZell "All time In" in Spalte C suchen
lzA = .Cells(Rows.Count, 3).End(xlUp).Row
'Sort End-Adresse aus Spalte und LastZell bilden
SortEndAdr = SortEndSpa & lzA
Application.ScreenUpdating = False
'** nur zur Bereichs Kontrolle für Sortierbereich
'.Range(SortAnfAdr, SortEndAdr).Select: Exit Sub
'Sortieren vorbereiten
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range(SAdr1), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sortbereich sortieren
With .Sort
.SetRange Range(SortAnfAdr, SortEndAdr)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub