Zeiträume zusammenfassen mit PQ oder VBA

[DioDe]

Hi liebe Excel Gemeinde,

seit Tagen durchforste ich das Internet/Forum nach eine Lösung für mein Problem, leider wurde ich bisher nicht fündig.

Ausgangslage ist ich bekomme Daten in einer Excel Datei welche zum Teil "überflüssige" Zeilen besitzen aber Betrieblich nun mal so erfasst werden.
Meine Aufgabe ist es nun diese Zeilen zusammen zufassen damit die Weiterverarbeitung besser funktioniert da die Daten dann übersichtlicher sind.

Voraussetzung für das zusammenfassen der Zeile muss sein (Bezogen auf die Beispieldatei)
A6=A7 und B6=B7 dann muss geschaut werden ob K6,L6 = H7,I7 wenn das zutrift dann wird K7,L7 das neue K6,L6 
Spalte D,E und F können einfach zusammen gefasst werden getrennt durch ein Komma
Spalte C kann gleiche Werte enthalten und daher müsste diese werte nur Zusammen gefasst werden wenn diese ungleich sind (bei zu hoher Komplexität riecht auch das einfache zusammenfassen mit Komma als Trennzeichen)

Ich hoffe es ist verständlich. Das gewünschte Ergebnis ist auch in der Beispiel Datei zu sehen.


  Beispiel Daten.xlsx (Größe: 19,21 KB / Downloads: 10)
(die Beispiel Datei ist anonymisiert und die Farben sollen nur der besseren Lesbarkeit dienen)

vorab schon mal vielen Dank 
Diode

[Stoffo]

Hallo,

anhand deiner Beispieldatei ist für mich auf Anhieb nicht ersichtlich wo hier konkrete Unterscheidungsmerkmale vorliegen. Der Abschnitt ist in allen Fällen 122, demnach macht eine Prüfung A6=A7 keinen Sinn, da diese Bedingung beim runterziehen überall erfüllt wäre. Gleiches gilt für Kunde_a und ebenfalls für deine Zeitenbedingung. Bitte ändere daher deine Datei entsprechend ab, oder (sofern es sich tatsächlich immer um den gleichen Kunden und Abschnitt handeln soll) präzisiere deine Ausführungen.

[DioDe]

das Hauptaugenmerk liegt hier auf die Zusammenhängenden Zeiträume 

wollte damit die beispiele Einfach halten, den einfand zu den Zeiten verstehe ich nicht ganz (die Zeiten sind reale Daten)

hier nochmal eine leicht angepasste Beispieldatei

  Beispiel Daten2.xlsx (Größe: 19,41 KB / Downloads: 7)

[Raoul21]

Hi, mal auf die Schnelle (ohne weiteren Support). LG, Raoul.

Code:

Sub Zusammenfassen()
   Const a As String = "A7"
   Dim c, i As Long
   With ActiveSheet.Range(a).CurrentRegion
      For i = 1 To .Rows.Count - 1
         If .Cells(i, "A") = .Cells(i + 1, "A") And _
            .Cells(i, "B") = .Cells(i + 1, "B") And _
            .Cells(i, "K") = .Cells(i + 1, "H") And _
            .Cells(i, "L") = .Cells(i + 1, "I") Then
            For Each c In Array("C")
               If .Cells(i, c) <> .Cells(i + 1, c) Then _
                  .Cells(i, c) = .Cells(i, c) & "," & .Cells(i + 1, c)
            Next c
            .Cells(i, "K") = .Cells(i + 1, "K")
            .Cells(i, "L") = .Cells(i + 1, "L")
            .Cells(i, "O") = .Cells(i, "O") + .Cells(i + 1, "O")
            .Rows(i + 1).Delete Shift:=xlUp
            i = i - 1
         End If
      Next i
   End With
End Sub

[DioDe]

@Raoul, danke für deine Lösung
ein Großteil funktioniert genau so wie beschrieben  :19:

nur das Spalte D,E und F nicht zusammen kopiert werden, glaub das bekomme ich aber selber hin.

und ein Problem tritt noch auf wenn ich die realen Daten nehme schmiert mir das Excel ab (man sieht das er die ersten Zeilen noch richtig verarbeitet) habe es erst mit 1500 Datensätzen versucht ... dann nochmal mit 500 aber leider noch das selbe Problem

Gruß DioDe

[Elex]

Hi

Versuch mal den Code. Der Code bearbeitet immer das aktive Blatt und bearbeitet die Liste direkt. Also vorher besser eine Kopie machen.

Code:

Public Sub Kürzen()
Dim j As Long, dict As Object

On Error GoTo Fehler

Set dict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

With Range("A3").CurrentRegion   'hier die linke obere Ecke der Tabelle
For j = 1 To .Rows.Count
  dict.RemoveAll
  dict(.Cells(j, 3).Text) = 1
  Do While .Cells(j + 1, 1) <> "" And .Cells(j, 1) = .Cells(j + 1, 1) And .Cells(j, 2) = .Cells(j + 1, 2) _
             And Format(.Cells(j, 11) + .Cells(j, 12), "dd.mm.yyyy hh:mm") = _
             Format(.Cells(j + 1, 8) + .Cells(j + 1, 9), "dd.mm.yyyy hh:mm")

       dict(.Cells(j + 1, 3).Text) = 1
      .Cells(j, 4) = .Cells(j, 4) & ", " & .Cells(j + 1, 4)
      .Cells(j, 5) = .Cells(j, 5) & ", " & .Cells(j + 1, 5)
      .Cells(j, 6) = .Cells(j, 6) & ", " & .Cells(j + 1, 6)
      .Cells(j, 11) = .Cells(j + 1, 11)
      .Cells(j, 12) = .Cells(j + 1, 12)
      .Rows(j).Offset(1).EntireRow.Delete
  Loop
   .Cells(j, 3) = Join(dict.keys, ", ")
   If .Cells(j + 1, 1) = "" Then Exit For
Next j
End With

Fehler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Set dict = Nothing
End Sub

Gruß Elex

[DioDe]

@Elex aufn ersten Blick läuft es genau so wie es soll MEGA :19: