Zeilen addieren /zusammenfassen

Hallo,
ich möchte redundante Datensätze bezogen auf die Spalten A - D zusammenfassen. Siehe Beispiel unten. Da es vorkommen kann, das Kunden mehrere Adressen innerhalb eines Ortes haben. Ausserdem sollen die Zellinhalte der nachfolgenden Spalten "addiert" werden wenn Sie zu einem Kunden gehören. Als Beispiel hat der Kunde ein Produkt gekauft mit dem Namen Z, siehe 1. Zeile weiter unten und dann hat er zu einem anderen Zeitpunkt nichts gekauft. Zusammengefasst hat er aber das Produkt mit dem Namen Z gekauft.
Vorher: (leer bedeutet Zelle ohne Inhalt )
Kunde...............PLZ........Ort.....Strasse........Produkt
Kunde A............xxxxx.....xxx......xxx..............Z
Kunde A............xxxxx.....xxx......xxx..............leer
Kunde B........................................................leer
Kunde B........................................................Y
Kunde A............xxxxx.....xxx.......yyy.............leer
Nachher: leer und X = X
Kunde.............PLZ.........Ort........Strasse...............Produkt
Kunde A..........xxxxx......xxx........xxx.....................Z
Kunde B................................................................Y
Kunde A..........xxxxx......xxx........yyy....................leer

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
hier der Code funktionsfähig mit deinem Bespiel:


Sub test()
Dim sp As Long
Dim ze As Long
Dim check As Boolean
'--- Sortieren
For sp = 5 To 1
Range("A1").CurrentRegion.Sort key1:=Cells(2, sp), order1:=xlAscending, header:=xlNo
Next
ze = 2
Do Until Cells(ze + 1, 1).Value = ""
'--- Prüfen, ob gelicher Kunde
check = True
For sp = 1 To 5
check = check And (Cells(ze, sp) = Cells(ze + 1, sp))
Next
Select Case check
Case False '--- Neuer Kunde, eine Zeile weiter
ze = ze + 1
Case True '--- gleicher Kunde, zusammenfassen
For sp = 6 To 19 'nummern der Spalten, die zusammengefasst werden sollen
If Cells(ze + 1, sp)  "" Then
Select Case IsNumeric(Cells(ze, sp))
Case True '--- Zahlen zusammenaddieren
Cells(ze, sp) = Cells(ze, sp) + Cells(ze + 1, sp)
Case False '--- Texte zusammenfassen
If Cells(ze, sp)  "" Then Cells(ze, sp) = Cells(ze, sp) & " " '  _
Trennzeichen
Cells(ze, sp) = Cells(ze, sp) & Cells(ze + 1, sp)
End Select
End If
Next sp
Rows(ze + 1).Delete
End Select
Loop
End Sub

Zellen, die Zahlen enthalten, werden beím Zusammenfassen zusammenaddiert, Zellen die Texte enthalten, werden mit einen Leerzeichen als Trennzeichen zusammengesezt
Aufpassen musst du mit der Zertifikats-Nr, die wird nach momentanen Stand aufaddiert.
Gruß, Daniel

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread