Werte aus Liste einmalig anzeigen VBA

Hallo zusammen,
in diesem Thread habe ich folgenden VBA Code gefunden:
https://www.herber.de/forum/archiv/732to736/733154_Werte_aus_einer_liste_nur_einmal_anzeigen.html

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ziel As Range
If Cells(1, Target.Column).Value  "xxx1" Then Exit Sub
If Application.WorksheetFunction.CountIf(Rows(1), "xxx2")  1 Then
MsgBox ("Kein EINdeutiger Zielbereich vorhanden ('xxx2' in Reihe 1)")
Exit Sub
End If
Set Ziel = Rows(1).Find(what:="xxx2").Offset(1, 0)
Range(Cells(2, Target.Column), Cells(2, Target.Column).End(xlDown)).AdvancedFilter Action:=  _
_
xlFilterCopy, CopyToRange:=Ziel, Unique:=True
End Sub

Wie kann ich den VBA Code so anpassen, dass in meiner Tabelle "Datenbasis" die Spalte B2 bis 75.000 (oder auch variabel) die Werte ausliest und jeden Namen einmalig ausgibt in z. B. das Tabellenblatt "Daten" ab Zeile A1.
Im gesamten Tabellenblatt "Datenbasis" sind unzählige Kundentransaktionen hinterlegt, in Spalte B werden die jeweiligen Kundennamen aufgeführt. Ich brauch nun eine Liste dieser Kunden - dabei soll jeder Kunde natürlich nur einmalig aufgeführt werden.
Eine Pivot Tabelle ist keine Option. Es muss über ein solches Makro laufen.
Vielen Dank!
PS: Ich weiß wo ich das Makro im Klassenmodul hinterlege, aber wie starte ich dieses Makro bzw. rufe es auf? Habe da absolut keine Ahnung!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub DerMakroname() Dim lRow As Long With Sheets("Datenbasis") lRow = .Cells(.Rows.Count, 2).End(xlUp).Row .Range("B2:B" & lRow).Copy End With With Sheets("Daten") .Range("A1").PasteSpecial .Range("$A$1:$A$" & lRow - 1).RemoveDuplicates Columns:=1, Header:=xlNo End With End Sub

Sub DerMakroname() Dim lRow As Long With Sheets("Datenbasis") lRow = .Cells(.Rows.Count, 2).End(xlUp).Row .Range("B2:B" & lRow).Copy End With With Sheets("Daten") .Range("A1").PasteSpecial .Range("$A$1:$A$" & lRow - 1).RemoveDuplicates Columns:=1, Header:=xlNo .Sort.SortFields.Clear .Sort.SortFields.Add Key:=.Range("$A$1:$A$" & lRow - 1), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal .Sort.SetRange .Range("A1:A12") .Sort.Header = xlGuess .Sort.MatchCase = False .Sort.Orientation = xlTopToBottom .Sort.SortMethod = xlPinYin .Sort.Apply End With End Sub

Sub DerMakroname() Dim lRow As Long With Sheets("Datenbasis") lRow = .Cells(.Rows.Count, 2).End(xlUp).Row .Range("B2:B" & lRow).Copy End With With Sheets("Daten") .Range("A1").PasteSpecial .Range("$A$1:$A$" & lRow - 1).RemoveDuplicates Columns:=1, Header:=xlNo .Sort.SortFields.Clear lRow = .Cells(.Rows.Count, 2).End(xlUp).Row .Sort.SortFields.Add Key:=.Range("$A$1:$A$" & lRow), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal .Sort.SetRange .Range("A1:A12") .Sort.Header = xlGuess .Sort.MatchCase = False .Sort.Orientation = xlTopToBottom .Sort.SortMethod = xlPinYin .Sort.Apply End With End Sub

Sub DerMakroname() Dim lRow As Long With Sheets("Datenbasis") lRow = .Cells(.Rows.Count, 2).End(xlUp).Row .Range("B2:B" & lRow).Copy End With With Sheets("Daten") .Range("A1").PasteSpecial .Range("$A$1:$A$" & lRow - 1).RemoveDuplicates Columns:=1, Header:=xlNo .Sort.SortFields.Clear lRow = .Cells(.Rows.Count, 2).End(xlUp).Row .Sort.SortFields.Add Key:=.Range("$A$1:$A$" & lRow), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal .Sort.SetRange .Range("A1:A" & lRow) .Sort.Header = xlGuess .Sort.MatchCase = False .Sort.Orientation = xlTopToBottom .Sort.SortMethod = xlPinYin .Sort.Apply End With End Sub

Sub Kunden_einmalig() Dim oDic As Object, arrQ, i As Long On Error GoTo ERRHDL Application.EnableEvents = False Set oDic = CreateObject("Scripting.dictionary") arrQ = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp)) For i = 1 To UBound(arrQ) oDic(arrQ(i, 1)) = 0 Next With Sheets("Daten").Columns(1) .ClearContents .Cells(1, 1).Resize(oDic.Count) = _ WorksheetFunction.Transpose(oDic.keys) End With ERRHDL: Application.EnableEvents = True End Sub

' Kopiert nur die eindeutigen Werte einer Spalte in ein anderes Blatt ' dessen Spaltenüberschrift in Zeile 1 genau gleich lautet ' Die Spalte muss lückenlos ohne Leerzeilen gefüllt werden. ' Anzupassen sind ggf. die Const Werte (sTitel, sZielBlatt) Private Sub Worksheet_Change(ByVal Target As Range) Const sTitel As String = "Kundenname" ' Spaltenüberschrift (Zeile 1) in dieser _ Tabelle Const sZielBlatt As String = "Daten" ' Blattnamen des Ziels Dim Ziel As Range If Cells(1, Target.Column).Value sTitel Then Exit Sub If Application.WorksheetFunction.CountIf(Worksheets(sZielBlatt).Rows(1), sTitel) 1 Then MsgBox "Im Zielblatt '" & sZielBlatt & "' fehlt der Spaltentitel ", _ vbExclamation Exit Sub End If Set Ziel = Worksheets(sZielBlatt).Rows(1).Find(what:=sTitel) Range(Cells(1, Target.Column), Cells(2, Target.Column).End(xlDown)).AdvancedFilter Action:= _ xlFilterCopy, CopyToRange:=Ziel, Unique:=True End Sub

Beliebteste Forumthreads (12 Monate)

Werte aus Liste einmalig anzeigen VBA

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

336 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte aus Liste einmalig anzeigen VBA

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

336 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread