Vul een keuzelijst met unieke waarden uit een werkblad met VBA in Microsoft Excel

Anonim

In dit artikel zullen we een keuzelijst in gebruikersvorm maken en deze met waarden laden na het verwijderen van dubbele waarden.

Ruwe data die we in de List Box zullen invoegen, bestaat uit namen. Deze onbewerkte gegevens bevatten dubbelhartigheid in gedefinieerde namen.

In dit voorbeeld hebben we een gebruikersformulier gemaakt dat bestaat uit List Box. Deze keuzelijst zal unieke namen uit de voorbeeldgegevens weergeven. Om het gebruikersformulier te activeren, klikt u op de verzendknop.

Dit gebruikersformulier retourneert de naam die door de gebruiker is geselecteerd als uitvoer in een berichtvenster.

Logische uitleg

Voordat we namen aan de keuzelijst toevoegden, hebben we een verzamelingsobject gebruikt om dubbele namen te verwijderen.

We hebben de volgende stappen uitgevoerd om dubbele vermeldingen te verwijderen: -

  1. Namen uit het gedefinieerde bereik in het Excel-blad toegevoegd aan verzamelingsobject. In collectieobject kunnen we geen dubbele waarden invoegen. Het Collection-object geeft dus een fout bij het tegenkomen van dubbele waarden. Om fouten af ​​te handelen, hebben we de foutverklaring "On Error Resume Next" gebruikt.

  2. Voeg na het voorbereiden van de verzameling alle items uit de verzameling toe aan de array.

  3. Voeg vervolgens alle array-elementen in de keuzelijst in.

Volg hieronder voor de code:

 Optie Explicit Sub running() UserForm1.Show End Sub 'Voeg onderstaande code toe in userform Optie Explicit Private Sub CommandButton1_Click() Dim var1 As String Dim i As Integer 'Doorloop alle waarden in de keuzelijst 'Toewijzen van de geselecteerde waarde aan variabele var1 For i = 0 Naar ListBox1.ListCount - 1 If ListBox1.Selected(i) Then var1 = ListBox1.List(i) Exit For End If Next 'Ontlaad het gebruikersformulier. Unload Me 'De geselecteerde waarde weergeven MsgBox "U hebt de volgende naam geselecteerd in de keuzelijst: " & var1 End Sub Private Sub UserForm_Initialize() Dim MyUniqueList As Variant, i As Long 'Calling UniqueItemList-functie 'Toewijzen van het bereik als invoerparameter MyUniqueList = UniqueItemList(Range("A12:A100"), True) With Me.ListBox1 'De inhoud van de keuzelijst wissen .Clear 'Waarden in de keuzelijst toevoegen For i = 1 To UBound(MyUniqueList) .AddItem MyUniqueList(i) Next i ' Het eerste item selecteren .ListIndex = 0 End With End Sub Private Function UniqueItemList(InputRange As Range, _ HorizontalList As Boolean) As Variant Dim cl As Range, cUnique As New Collection, i As Long 'Declaring a dynamic array Dim uList() As Variant 'Deze functie als vluchtig verklaren 'Betekent dat de functie opnieuw wordt berekend wanneer de berekening in een cel plaatsvindt Toepassing.Volatile On Error Resume Next 'Items toevoegen aan verzameling' Alleen uniek item wordt ingevoegd 'Het invoegen van een dubbel item zal door een fout voor elk cl In InputRange If cl.Value "" Then 'Waarden toevoegen aan verzameling cUnique.Add cl.Value, CStr(cl.Value) End If Next cl 'Initialiseren van waarderetour door de functie UniqueItemList = "" If cUnique.Count > 0 Then 'Resizing the array size ReDim uList(1 To cUnique.Count) 'Waarden van verzameling in array invoegen For i = 1 To cUnique.Count uList(i) = cUnique(i) Next i UniqueItemList = uList 'De waarde van HorizontalList controleren' Als de waarde waar is, wordt de waarde van UniqueItemList getransponeerd Indien niet HorizontalList Dan UniqueItemList = _ Application.WorksheetFunction.Transpose (UniqueItemList) End If End If On Error GoTo 0 End Function 

Als je deze blog leuk vond, deel hem dan met je vrienden op Facebook. Ook kunt u ons volgen op Twitter en Facebook.

We horen graag van u, laat ons weten hoe we ons werk kunnen verbeteren en voor u kunnen verbeteren. Schrijf ons op de e-mailsite