Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Zeiträume zusammenfassen mit PQ oder VBA
#1
Question 
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.


.xlsx   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
Antwortento top
#2
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.
Gruß

Stoffo
Antwortento top
#3
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

.xlsx   Beispiel Daten2.xlsx (Größe: 19,41 KB / Downloads: 7)
Antwortento top
#4
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
Antwortento top
#5
@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
Antwortento top
#6
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
Antwortento top
#7
@Elex aufn ersten Blick läuft es genau so wie es soll MEGA 19
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste