2 Tabellen in eine kopieren / sortieren per Makro

[Gast 123]

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

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

[Gast 123]

Nachtrag  was vergessen

für den neuen Code benötige ich in "All time In" eine Hilfsspalte, habe die Spalte BJ genommen für das Datum zu kopieren!!

Beim Spaltenweisen kopieren prüfe ich nicht jede einzelne Zeile ob das Datum gültig ist oder nicht. Da wird nur kopiert, geht wesentlich schneller als die For Next Schleife mit Einzelprğfung!  Dafür muss ich nach dem kopieren die ungültigen Daten wieder löschen, und sortiere anschliessend den ganzen Datensatz. Damit fallen die Leerzeilen automatich weg. Geht schneller als die For Next Schleife.

In den einzelnen Makro habe ich den Befehl:  Application.ScrrenUpdatin = True gelöscht!!  Es macht keinen Sinn den Bildschirm zwischendurch wieder neu aufzubauen, wenn ich noch mehr kopiere und lösche!!  Kostet nur unnötige Zeit!!  

mfg  Gast 123