[Excel, VBA] Aus Liste Duplikate entfernen
Gepostet am: Jun 14, 2011 12:37:19 PM
Basierend auf den letzten Blog-Eintrag, habe ich mir die Frage gestellt, ob es auch möglich ist mit einer Matrixformel die Liste um die doppelt vorkommenden Einträge zu bereinigen.
Ausgangslage ist also eine Liste (links) und Ziel ist es eine um doppelte Einträge bereinigte Liste (rechts)
Liste bereinigen mittels Matrix Formel
Unter Excelformeln.de findet man eine funktionierende Lösung mit einer Matrixformel. Diese funktioniert aber nur eingeschränkt.
Wenn die Liste nicht in der Zeile 1 anfängt, oder dergleichen, kommt es zu Fehlern, wie nachfolgender Screenshot zeigt:
So wirklich zufriedenstellend ist in meinen Augen die Lösung nicht, zumal mittels VBA recht einfach eine derartige Lösung gebastelt werden kann.
Liste bereinigen mittels VBA
Die angesprochene Lösung mittels VBA würde beispielsweise so aussehen:
Liste bereinigen
Function Liste_bereinigen(myRange As range, Optional wennLeer As String = "", Optional bVertikal As Boolean = True) As VariantDim myArray() As VariantReDim Preserve myArray(myRange.Count - 1)Dim myCell As range Dim i As IntegerDim bContains As BooleanDim Counter As Integer Counter = 0For Each myCell In myRange bContains = False For i = 0 To Counter If myArray(i) = myCell.Value Then bContains = True Exit For End If Next If bContains = False Then myArray(Counter) = myCell.Value Counter = Counter + 1 End IfNext'den restlichen Array befüllenFor i = Counter To myRange.Count - 1 myArray(i) = wennLeer NextIf bVertikal = True Then Liste_bereinigen = Application.WorksheetFunction.Transpose(myArray())Else Liste_bereinigen = myArray()End If End Function
Wie folgende Screenshots zeigen funktioniert das sowohl bei senkrecht als auch waagrecht ausgerichteten Ausgangsmaterial. Und auch die Ergebnisliste kann je nach Geschmack angeordnet werden.
Jetzt existieren (in meinen Augen) jedoch noch 2 Schönheitsfehler:
kann man die Listen nicht gleich auch sortieren
wie sieht es bei mehrspaltigen Listen aus.
Liste bereinigen und sortieren mittels VBA
Wie bereits angesprochen, wäre es schön die Listen nicht nur um doppelte Werte zu bereinigen, sondern auch zu sortieren. Zum Thema sortieren unter VBA gibt es folgende Anleitung: Array Sortieren.
Der adaptierte Code würde dann so aussehen:
Liste bereinigen und sortieren
Function Liste_bereinigen(myRange As range, Optional wennLeer As String = "", _ Optional bVertikal As Boolean = True, Optional bSortiert As Boolean = False) As VariantDim myArray() As VariantReDim Preserve myArray(myRange.Count - 1)Dim myCell As range Dim i As IntegerDim bContains As BooleanDim Counter As Integer Counter = 0For Each myCell In myRange bContains = False For i = 0 To Counter If myArray(i) = myCell.Value Then bContains = True Exit For End If Next If bContains = False Then myArray(Counter) = myCell.Value Counter = Counter + 1 End IfNext'ggf sortierenIf bSortiert = True Then Dim tmpArray() As Variant tmpArray = myArray ReDim Preserve tmpArray(0 To Counter - 1) 'jetzt haben wir einen Array, der nur die um die doppelten 'Bereinigte Liste enthält - diese jetzt sortieren Call QuickSort(tmpArray, LBound(tmpArray), UBound(tmpArray)) 'jetzt den ReDim Preserve tmpArray(0 To myRange.Count - 1) myArray = tmpArray ElseEnd If'den restlichen Array befüllenFor i = Counter To myRange.Count - 1 myArray(i) = wennLeer NextIf bVertikal = True Then Liste_bereinigen = Application.WorksheetFunction.Transpose(myArray())Else Liste_bereinigen = myArray()End If End Function
Das funktioniert natürlich auch mit Text
Liste aufsummieren
Etwas kompizierter wird es mit mehreren Spalten, wovon nach einer Sortiert, weitere übernommen und nochmals weitere aufsummiert werden sollen. Also in etwa sowas (inklusive dessen Umsetzung als Pivot Tabelle)
Dies kann man mit der SummeWENN Funktion Lösen, wenn man die Liste (im konkreten Fall die Kontonummer) um die Duplikate bereinigt hat.
Eine schönere - und weitaus mächtigere - Lösung ist die Funktion Liste_aufsummieren.
Liste_aufsummieren
Function Liste_aufsummieren(Spalte1 As range, Spalte2 As range, Spalte3 As range, Optional sleer As String = "") As VariantOn Error Resume Next'1. Schritt prüfen, ob die Spalten gleich viele Zeilen habenIf (Spalte1.Rows.Count <> Spalte2.Rows.Count) Or (Spalte1.Rows.Count <> Spalte3.Rows.Count) Then MsgBox "Ungleiche Anzahl von Zeilen", vbCritical + vbOKOnly, "Fehler" Liste_aufsummieren = "#Fehler" Exit FunctionEnd IfIf Spalte1.Columns.Count <> 1 Then MsgBox "Die Spalte, nach der bereinigt werden soll, darf nur 1 Zelle breit sein" Liste_aufsummieren = "#Fehler" Exit FunctionEnd If' 2. Schritt einen entsprechenden Array erstellenDim myArray() As VariantDim AnzahlZeilen As Integer AnzahlZeilen = Spalte1.Rows.Count - 1Dim AnzahlSpaltenGesamt As Integer AnzahlSpaltenGesamt = Spalte1.Columns.Count + Spalte2.Columns.Count + Spalte3.Columns.Count - 1ReDim myArray(AnzahlZeilen, AnzahlSpaltenGesamt)'HilfsvariablenDim j As IntegerDim myCell As range Dim Counter As IntegerDim bContains As BooleanDim ZeilenCounter As IntegerDim ifound As Integer'Dimensionen des ArraysDim Spalte2Beginn As Integer Spalte2Beginn = 1Dim Spalte2Ende As Integer Spalte2Ende = Spalte2Beginn + Spalte2.Columns.Count - 1Dim Spalte3Beginn As Integer Spalte3Beginn = Spalte2.Columns.Count + 1Dim Spalte3Ende As Integer Spalte3Ende = Spalte3Beginn + Spalte3.Columns.Count - 1 ZeilenCounter = -1 Counter = 0 ifound = -1For Each myCell In Spalte1 ZeilenCounter = ZeilenCounter + 1 bContains = False For i = 0 To Counter If myArray(i, 0) = myCell.Value Then bContains = True ifound = i Exit For End If Next If bContains = False Then myArray(Counter, 0) = myCell.Value 'Primärspalte befüllen For j = Spalte2Beginn To Spalte2Ende myArray(Counter, j) = Spalte2.Cells(Counter + 1, j - Spalte2Beginn + 1) Next For j = Spalte3Beginn To Spalte3Ende myArray(Counter, j) = Spalte3.Cells(Counter + 1, j - Spalte3Beginn + 1) Next Counter = Counter + 1 ElseIf bContains = True Then For j = Spalte3Beginn To Spalte3Ende myArray(ifound, j) = myArray(ifound, j) + Spalte3.Cells(ZeilenCounter + 1, j - Spalte3Beginn + 1) Next ifound = -1 End IfNextFor i = Counter To UBound(myArray, 1) For j = LBound(myArray, 2) To UBound(myArray, 2) myArray(i, j) = sleer NextNext'Array zurückgeben Liste_aufsummieren = myArray()End Function