Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
2012to2016
2012to2016
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Anzeige
Inhaltsverzeichnis

Nur eindeutige Werte übernehmen

Forumthread: Nur eindeutige Werte übernehmen

Nur eindeutige Werte übernehmen
17.06.2025 16:19:23
Marc
Hallo,

ich habe folgendes Problem zu lösen:

In Spalte 9 (I) stehen ca. 3000 Namen von Kunden. Diese sollen nun in eine Userform Listbox übertragen werden. Allerdings möchte ich, dass nur eindeutige Namen übernommen werden. Doppelte Nennung soll nicht vorhanden sein. Ich suche nun schon seit Tagen nach einer Lösung und habe einiges ausprobiert.

Ich habe es mit folgenden Code probiert: 

Dim eregebnisse() As String

Dim znr As Integer, spnr As Integer

Dim fundstelle As Integer, i As Integer

Dim isDuplicate As Boolean



spnr = 9

znr = 2



ReDim ergebnisse(fundstelle)



 While Cells(znr, spnr) > ""

    isDuplicate = False

    ReDim Preserve ergebnisse(fundstelle)

    ergebnisse(fundstelle) = Cells(znr, spnr)

    fundstelle = fundstelle + 1

    znr = znr + 1

Wend


So werden aber nur alle Namen in die Listbox geschrieben. Ich bin langsam am verzweifeln. Wo liegt mein Fehler??

Hat von euch jemand eine Idee, wie ich den Code erweitern / ändern muss?

Danke und viele Grüße.
Anzeige

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Probiere es mal...
17.06.2025 16:40:02
Case
Moin Marc, :-)

... so: ;-) 
Option Explicit

Private Sub UserForm_Initialize()

    ListBox1.List = Application.Evaluate("=DROP(UNIQUE(Tabelle1!I:.I),1)")

End Sub

Oder - wenn das mit dem Punkt nicht klappt, dann so: ;-) 
Private Sub UserForm_Initialize()

    ListBox1.List = Application.Evaluate("=UNIQUE(Tabelle1!I2:I5000)")

End Sub

Das Tabelle1 musst du gegebenenfalls auf deinen Tabellenblattnamen anpassen, oder du kannst Tabelle1! (also mit Ausrufezeichen) weglassen, wenn du beim starten der UserForm auf dem Tabellenblatt mit den Daten bist. ;-)

Servus
Case
Anzeige
AW: Nur eindeutige Werte übernehmen
17.06.2025 16:46:55
UweD
Hallo


bei deiner Version ... 

Private Sub UserForm_Initialize()

    Dim TB As Worksheet, Ergebnis(), WF

    Set TB = Sheets("Tabelle1")

    Set WF = WorksheetFunction

    

    Ergebnis = WF.Sort(WF.Unique(WF.Filter(TB.Columns(9), WF.IsText(TB.Columns(9)))))

    

    With UserForm1.ListBox1

        .Clear

        .List = Ergebnis

    End With



End Sub



LG UweD
Anzeige
AW: Nur eindeutige Werte übernehmen
17.06.2025 18:42:31
daniel
Hi
wenn es von der Geschwindigkeit her reicht, würde ich die Werte ohne Zwischenarray direkt in die Listbox schreiben.
über die .List-Funktion agiert sie selber wie ein Array, hat aber den Vorteil, dass man Werte nicht nur am Ende, sondern auch zwischendrin einfügen kann.
damit kann man dann mit ganz einfacher Programmierung ohne irgendwelche speziellen Funktionen nutzen zu müssen, nicht nur eine duplikatfreie, sondern auch gleich eine sortierte Liste erstellen: 

Dim Wert

Dim i As Long

With ListBox1

    .Clear

    For Each Wert In Range(Cells(2, 9), Cells(Rows.Count, 9).End(xlUp).Row).Value

        For i = 0 To .ListCount - 1

            If .List(i) >= Wert Then Exit For

        Next

        If i > .ListCount - 1 Then

            .AddItem Wert

        ElseIf .List(i) > Wert Then

            .AddItem Wert, i

        End If

    Next

End With


gruß Daniel
Anzeige
DANKE!
18.06.2025 14:16:45
Marc
@ Case, Daniel, UweD und RPP63:

Vielen Dank für eure Hilfe und die sehr schnellen Antworten! Mein Dynamisches Array läuft und ich habe es verstanden :)

Die anderen Varianten werde ich mir jetzt sehr genau ansehen und ausprobieren. Ich danke euch!

Viele Grüße
Marc
AW: Probiere es mal...
17.06.2025 16:45:23
daniel
Hi

gute Idee, die neuen ExcelFunktionen auch in VBA zu nutzen.
bei mir ist UNIQUE in den WorksheetFunctions enthalten, man muss da nicht über Evaluate gehen: 


Listbox1.List = Worksheetfunction.Unique(Range("I2.:.I99999"))


Gruß Daniel
Anzeige
AW: Probiere es mal...
17.06.2025 16:49:59
Marc
Hallo Case,

das ist der Hammer. Läuft super und macht was es soll. Vielen Dank für diesen Lösungsansatz.

Vielleicht hat noch jemand eine Idee, wie ich es mit einem Dynamischen Array lösen kann. Ist definitiv umständliches als die Lösung von Case aber ich habe damit angefangen und möchte meinen Fehler verstehen und mein Wissen erweitern und nicht einfach nur abschreiben :)

Viele Grüße
Anzeige
AW: Probiere es mal...
17.06.2025 17:06:14
daniel
naja in deinem Code fehlt noch vollständig die Prüfung, ob der Name schon im Array drin ist oder nicht.
du hast dir zwar ein "isDuplicate" als Variable angelegt, aber mehr nicht.

wenn dann so (Prinzip, kein kopierfähiger Code) 

While Cells(znr, spnr) > ""

    for i = lbound(ergebnisse) to ubound(ergebnisse)

        if ergebnisse(i) = Cells(znr, spnr) then Exit for

    next

    if i > Ubound(ergebnisse) then

        ReDim Preserve ergebnisse(i)

        ergebnisse(i) = Cells(znr, spnr)

    end if

    znr = znr + 1

Wend


die Prüfung erfolgt hier nach folgendem Prinzip:
man läuft per Schleife durch alle Elemente des Arrays
die Schleife wird vorzeitig abgebrochen, wenn der Wert im Array vorhanden ist.
ob eine Schleife vorzeitig abgebrochen wurde, erkennt man daran, dass der Schleifenzähler größer ist als der Schleifenendwert.

Gruß Daniel
Anzeige
Du könntest auch ein...
17.06.2025 17:38:30
Case
Moin Marc, :-)

... Dictionary nehmen: ;-) 
Option Explicit

Private Sub UserForm_Initialize()

    Dim varArr() As Variant

    Dim objDict As Object

    Dim lngCount As Long

    Set objDict = CreateObject("Scripting.Dictionary")

    With Tabelle1

        varArr = .Range("I2:I" & .Cells(.Rows.Count, "I").End(xlUp).Row).Value

        For lngCount = LBound(varArr, 1) To UBound(varArr, 1)

            If Not objDict.Exists(varArr(lngCount, 1)) And varArr(lngCount, 1) > "" Then

                objDict.Add varArr(lngCount, 1), Nothing

            End If

        Next lngCount

    End With

    ListBox1.List = objDict.Keys

End Sub

Servus
Case
Anzeige
Die neuen Funktionen...
17.06.2025 17:50:22
Case
Moin Marc, :-)

... sind schon klasse. ;-)

Und - wenn möglich - nutze ich sie in VBA. ;-)

Mit EVALUATE gehen dann auch solche Dinge: ;-) 
=LET(x;ABSCHNBEREICH(Tabelle1!I:I);y;"I_2";SORTIEREN(EINDEUTIG(FILTER(x;LINKS(x;3)=y))))

Sprich...
Keine letzte belegte Zelle suchen - das macht ABSCHNBEREICH. ;-)
Keine Doppelten/Mehrfachen. ;-)
Sortiert. ;-)
Und nur Kunden, die mit "I_2" anfangen. ;-)

ABSCHNBEREICH lässt sich mit Punkten abkürzen: ;-)
https://support.microsoft.com/de-de/office/trimrange-funktion-d7812248-3bc5-4c6b-901c-1afa9564f999

Im UserForm dann: ;-) 
ListBox1.List = Application.Evaluate("=LET(x,TRIMRANGE(Tabelle1!I:I),y,""I_2"",SORT(UNIQUE(FILTER(x,LEFT(x,3)=y))))")


Servus
Case
Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Live-Forum - Die aktuellen Beiträge
Datum
Titel
14.05.2026 13:31:09
Zeichen ausblenden
14.05.2026 09:50:42
Makro für MacOs
13.05.2026 19:14:18
Gleichheitszeichen
13.05.2026 14:24:56
VBA Projekt Passwort automatisch eingeben
13.05.2026 08:49:41
Reale Berechnung ohne Nachkommawerte
Keine passende Antwort im Forumarchiv gefunden?
Stelle deine Frage im Live-Forum