Clever-Excel-Forum

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.

[attachment=33532]
(die Beispiel Datei ist anonymisiert und die Farben sollen nur der besseren Lesbarkeit dienen)

vorab schon mal vielen Dank
Diode

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.

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
[attachment=33535]

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

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

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

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

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

DioDe

Stoffo

DioDe

Raoul21

DioDe

Elex

DioDe