[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

weiterführende Links

• Formellösungen für Spezialfilter ohne Duplikate