Mit diesem Makro werden alle nicht doppelten Daten aus Spalte A in Spalte B geschrieben.
Jeder Wert wird also maximal einmal in Spalte B geschrieben, egal, wie oft er in Spalte A vorhanden ist.
Die Unikate werden sozusagen extrahiert und in Spalte B geschrieben.
Sub ListeUnikate()
Dim Liste As New Collection
Dim i As Integer
Dim j As Integer
Dim Gefunden As Boolean
Liste.Add [A1]
For i = 2 To 20 'oder so viele, wie Du brauchst
Gefunden = False
For j = 1 To Liste.Count
If Cells(i, 1) = Liste(j) Then Gefunden = True
Next j
If Not Gefunden Then Liste.Add Cells(i, 1)
Next i
'Zu Testzwecken
For i = 1 To Liste.Count
Cells(i, 2) = Liste(i)
Next i
End Sub
Herr Kühnlein hat den Code erweitert. Nun wird in Spalte C protokolliert, welche Daten, wie oft in Spalte A vorhanden sind. Eine super Sache!
Sub ListeUnikate_mit_zähler()
Dim n As Integer
Dim i As Integer
Dim j As Integer
Dim Gefunden As Boolean
[B1] = [A1]
[C1] = 1
n = 1
For i = 2 To 9 'oder so viele wie gewünscht
Gefunden = False
For j = 1 To n
If Cells(i, 1) = Cells(j, 2) Then
Gefunden = True
Cells(j, 3) = Cells(j, 3) + 1
End If
Next j
If Not Gefunden Then
n = n + 1
Cells(n, 2) = Cells(i, 1)
Cells(n, 3) = 1
End If
Next i
End Sub
Die Veröffentlichung wurde frundlicherweise von Klaus Kühnlein genehmigt.
Anfrage per E-Mail
+49(0) 151 164 55 914
Anfrage per Kontaktformular
Hilfe-Forum
