Spalten-Konsolidierung identischer Zeilen
Ausgangslage - Was tut dieser Code-Schnipsel?
Folgende Situation: Sie haben eine Gerätetabelle und möchten gerne alle
Seriennummern eines Gerätetyps mit einem Komma getrennt in der Spalte Seriennummern haben.
Zur Verdeutlichung einmal die Tabelle1 (Ausgangslage) und die gewünschte Auswertungstabelle (Ergebnis).
| A | B | C | D | E | F | |
|---|---|---|---|---|---|---|
| 1 | Name | Hersteller | Typ | Preis | Seriennummern | |
| 2 | Maus | Hersteller A | 1 | 50 Euro | A223B442 | |
| 3 | Maus | Hersteller A | 1 | 50 Euro | A223B442 | |
| 4 | Monitor | Hersteller B | 1 | 199 Euro | X333J598 | |
| 5 | Gehäuse | Hersteller C | 2 | 99 Euro | F456Z662 | |
| 6 | Gehäuse | Hersteller C | 2 | 99 Euro | F456Z667 | |
| 7 | Tastatur | Hersteller A | 1 | 29 Euro | T661H532 | |
| 8 | Tastatur | Hersteller A | 1 | 29 Euro | T662H522 |
| A | B | C | D | E | F | |
|---|---|---|---|---|---|---|
| 1 | Name | Hersteller | Typ | Preis | Seriennummern | |
| 2 | Maus | Hersteller A | 1 | 50 Euro | A223B442, A223B442 | |
| 3 | Monitor | Hersteller B | 1 | 199 Euro | X333J598 | |
| 4 | Gehäuse | Hersteller C | 2 | 99 Euro | F456Z662, F456Z667 | |
| 5 | Tastatur | Hersteller A | 1 | 29 Euro | T661H532, T662H522 | |
| 6 |
Der Quelltext
Option Explicit
Option Compare Text
' Original-Quelltext unter: https://www.online-vba.de/spalten-konsolidierung-identischer-zeilen
' Express-Hilfe für VBA unter https://www.online-vba.de/vba-expresshilfe
' Es gelten die Nutzungsbedingungen von Online-VBA.de
Public Sub OVBAde_TabellenKonsolidierung()
Dim lQuellZeile As Long
Dim lZielZeile As Long
Dim lSpalte As Long
Dim lSuchZeile As Long
Dim oQuelle As Object
Dim oZiel As Object
Dim bFlag As Boolean
Dim sVergleichQuelle As String
Dim sVergleichZiel As String
Set oQuelle = Sheets("Tabelle1")
Set oZiel = Sheets.Add
lZielZeile = 2
Application.ScreenUpdating = False 'Flackern ausschalten
'Überschriften eintragen
For lSpalte = 1 To 5
oZiel.Cells(1, lSpalte).Value = oQuelle.Cells(1, lSpalte).Value
Next lSpalte
'Konsolidierung
For lQuellZeile = 2 To oQuelle.UsedRange.Rows.Count + oQuelle.UsedRange.Row - 1
bFlag = False
'Prüfen ob Zeile schon vorhanden!
For lSuchZeile = 2 To oZiel.UsedRange.Rows.Count + oZiel.UsedRange.Row - 1
sVergleichQuelle = ""
sVergleichZiel = ""
For lSpalte = 1 To 4
sVergleichQuelle = sVergleichQuelle & CStr(oQuelle.Cells(lQuellZeile, lSpalte).Text)
sVergleichZiel = sVergleichZiel & CStr(oZiel.Cells(lSuchZeile, lSpalte).Text)
Next lSpalte
If LCase(Trim(CStr(sVergleichQuelle))) = LCase(Trim(CStr(sVergleichZiel))) Then
bFlag = True
Exit For
End If
Next lSuchZeile
'Prüfergebnis entscheidet ob bereits vorhanden oder eine neue Zeile angelegt werden muss
If bFlag = True Then 'Bereits vorhanden also nur anhängen
oZiel.Cells(lSuchZeile, 5).Value = oZiel.Cells(lSuchZeile, 5).Text & _
", " & oQuelle.Cells(lQuellZeile, 5).Text
Else 'Zeile als neu unten anhängen
For lSpalte = 1 To 5
'Inhalt übertragen ein führendes ' erzwingt die Textübernahme!!!
oZiel.Cells(lZielZeile, lSpalte).Value = _
CStr("'" & oQuelle.Cells(lQuellZeile, lSpalte).Value)
Next lSpalte
lZielZeile = lZielZeile + 1
End If
Next lQuellZeile
'Aufräumen
Application.ScreenUpdating = True
Set oZiel = Nothing
Set oQuelle = Nothing
End Sub
Anmerkungen und Hinweise
Dieser Codeschnipsel wurde geschrieben von Marc Wershoven im Jahr 2013.
Die Nutzung erfolgt auf eigene Gefahr.
Bitte denken Sie immer zuerst an eine ausreichende Datensicherung.
Wir können keinen kostenlosen Support anbieten.
Es gelten unsere Nutzungsbedingungen.
