Sortieren mit Vorgabe

Option Explicit
  
  
Sub ZusammenfassungDerMessergebnisse()

 ->Quelldaten Beschreibung
 ->Spalten
  Const c_SP_Schicht = 1
  Const c_SP_Werkzeug = 2
  Const c_SP_Datum = 3
  Const c_SP_Ausschuss = 4
  Const c_SP_Stueckzahl = 5
 ->Zeilen
  Const c_Z_ersteWertZeile = 2
  
 ->Ersatzstrings LC/RC und LH/RH
  Const c_Sorte_LCRC = LC/RC
  Const c_Sorte_LHRH = LH/RH
  
  Dim ws As Worksheet, r As Range
  Dim l_rows As Long, x As Long
  Dim s_Werkzeugsorte As String
  
  Set ws = ActiveSheet
 ->Blatt kopieren
  ws.Copy After:=ws
  Set ws = ActiveSheet
 ->Zeilenanzahl feststellen
  l_rows = ws.Cells(ws.Rows.Count, c_SP_Schicht).End(xlUp).Row
  
 ->Werkzeug durch Werkzeug-Sorte ersetzen
  For x = c_Z_ersteWertZeile To l_rows
    s_Werkzeugsorte = UCase(Left(ws.Cells(x, c_SP_Werkzeug).Value, 2))
    If s_Werkzeugsorte = LC Or s_Werkzeugsorte = RC Then
      ws.Cells(x, c_SP_Werkzeug).Value = c_Sorte_LCRC
    ElseIf s_Werkzeugsorte = LH Or s_Werkzeugsorte = RH Then
      ws.Cells(x, c_SP_Werkzeug).Value = c_Sorte_LHRH
    Else
      MsgBox (Unbekanntes Werkzeug in Zeile  & x)
      ws.Cells(x, c_SP_Werkzeug).Select
      GoTo Aufraeumen
    End If
  Next
  
 ->Sortierbereich definieren
  Set r = ws.Range( _
            Cells(c_Z_ersteWertZeile, c_SP_Schicht), _
            Cells(l_rows, c_SP_Stueckzahl))
  
 ->Nach Tag und Schicht und Werkzeugkennung sortieren
  r.Sort _
    Key1:=ws.Cells(c_Z_ersteWertZeile, c_SP_Datum), _
    Order1:=xlAscending, _
    Key2:=ws.Cells(c_Z_ersteWertZeile, c_SP_Schicht), _
    Order2:=xlAscending, _
    Key3:=ws.Cells(c_Z_ersteWertZeile, c_SP_Werkzeug), _
    Order3:=xlAscending, _
    Header:=xlNo
  
 ->für gleiche TAG/SCHICHT/WERKZEUGKENNUNG zusammenfassen
  For x = l_rows To c_Z_ersteWertZeile + 1 Step -1
    If (ws.Cells(x, c_SP_Datum).Value = ws.Cells(x - 1, c_SP_Datum).Value) And _
      (ws.Cells(x, c_SP_Schicht).Value = ws.Cells(x - 1, c_SP_Schicht).Value) And _
      (ws.Cells(x, c_SP_Werkzeug).Value = ws.Cells(x - 1, c_SP_Werkzeug).Value) Then
      
     ->gleich -> Werte auf x-1 aufaddieren
      ws.Cells(x - 1, c_SP_Ausschuss).Value = _
      ws.Cells(x - 1, c_SP_Ausschuss).Value + ws.Cells(x, c_SP_Ausschuss).Value
      ws.Cells(x - 1, c_SP_Stueckzahl).Value = _
      ws.Cells(x - 1, c_SP_Stueckzahl).Value + ws.Cells(x, c_SP_Stueckzahl).Value
     ->Zeile x löschen
      ws.Rows(x).Delete
    End If
  Next
  
Aufraeumen:
  Set ws = Nothing: Set r = Nothing
End Sub