Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema ListBox
BildScreenshot zu ListBox ListBox-Seite mit Beispielarbeitsmappe aufrufen

Fill Listbox with Unique Values of Col

Betrifft: Fill Listbox with Unique Values of Col von: Nilo
Geschrieben am: 09.09.2020 09:25:01

Hi zusammen,
ich habe einen kleine Kopfnuss zu lösen:

1 - lese eine Combobox aus und finde den Header (ok)
2 - Schreibe alle Values aus der gefundenen Spalte Distinct in eine Listbox (ok)
3 - (hier brauche ich Hilfe) - es soll nicht

  • xRgUni.EntireColumn.SpecialCells(xlCellTypeVisible)
  • sein,
    sondern "xRgUni.Zeile 2 bis letzte -2" der gefundenen Spalte
  • xRgUni.Cells(Rows.Count, 1).End(xlUp).usw klappt nicht


  • Danke mal im Voraus
    Gruß
    Nilo

  • Private Sub ComboBox1_Change()
        Dim xRg As Range
        Dim xRgUni As Range
        Dim xFirstAddress As String
        Dim xStr As String
        On Error Resume Next
        xStr = ComboBox1.Value
        Set xRg = Range("G1:H1").Find(xStr, , xlValues, xlWhole, , , True)
        If Not xRg Is Nothing Then
            xFirstAddress = xRg.Address
            Do
                Set xRg = Range("G1:H1").FindNext(xRg)
                If xRgUni Is Nothing Then
                    Set xRgUni = xRg
                Else
                    Set xRgUni = Application.Union(xRgUni, xRg)
                End If
            Loop While (Not xRg Is Nothing) And (xRg.Address <> xFirstAddress)
        End If
        
        Dim cell As Range
        Dim MyArr  As Variant, i As Long
    
    ' intialize array to high number of elements at start
    ReDim MyArr(0 To 10000)
    ' work on sheets "mysheet" according to PO
    With Sheets("mysheet")
    
        For Each cell In xRgUni.EntireColumn.SpecialCells(xlCellTypeVisible)
            MyArr(i) = cell.Value ' read all visible cells to array
            i = i + 1
        Next cell
        ' reduce array size to populated elements only
        ReDim Preserve MyArr(0 To i - 1)
        ' populate listbox with array
        ListBox3.List = RemoveDupesDict(MyArr)
    End With
    End Sub


  • Public Function RemoveDupesDict(MyArray As Variant) As Variant
    'DESCRIPTION: Removes duplicates from your array using the dictionary method.
    'NOTES: (1.a) You must add a reference to the Microsoft Scripting Runtime library via
    ' the Tools > References menu.
    ' (1.b) This is necessary because I use Early Binding in this function.
    ' Early Binding greatly enhances the speed of the function.
    ' (2) The scripting dictionary will not work on the Mac OS.
    'SOURCE: https:// _
    wellsr.com/vba/2017/excel/vba-remove-duplicates-from-array/
    
    '-----------------------------------------------------------------------
        Dim i As Long
        Dim d As Scripting.Dictionary
        Set d = New Scripting.Dictionary
        With d
            For i = LBound(MyArray) To UBound(MyArray)
                If IsMissing(MyArray(i)) = False Then
                    .item(MyArray(i)) = 1
                End If
            Next
            RemoveDupesDict = .Keys
        End With
    End Function

  • Betrifft: AW: Fill Listbox with Unique Values of Col
    von: GerdL
    Geschrieben am: 09.09.2020 10:20:15

    Moin Nilo!

    Es ist übertrieben die Find-Methode auf nur zwei Zellen anzusetzen.
    Der vielleicht nur theoretische Fall, dass dies Methode keinen Treffer liefert,
    ist m.E. nicht abgedeckt.

    Bereich - Zeile 2 bis letzte Zeile-2 - ermitteln:
    Sub Unit()
    
        Dim Rng As Range, Col As Range, lastRow As Long
       
        
        Set Rng = Range("G1:H1").EntireColumn
        
        For Each Col In Rng.Columns
            lastRow = Application.Max(lastRow, Col.Cells(Rows.Count).End(xlUp).Row)
        Next
        
        lastRow = lastRow - 2
        Set Rng = Range(Cells(2, Rng.Column), Cells(lastRow, Rng.Column + Rng.Columns.Count - 1))
        
        MsgBox Rng.Address
        Set Rng = Nothing
    
    
    End Sub
    

    Gruß Gerd

    Betrifft: AW: Fill Listbox with Unique Values of Col
    von: Daniel
    Geschrieben am: 09.09.2020 10:25:21

    Hi
    naja, xRgUni ist die Zelle in der Überschriftenzeile.
    vorausgesetzt, es wird nur eine Spalte gefunden (dein Code ermöglicht aber auch mehrere Spalten!)
    ggf so

    a) wenn keine Leerzellen in der Spalte vorkommen können:
    For Each cell In Range(xRgUni.Offset(1, 0), xRgUni.End(xldown))
    b) wenn Leerzellen möglich sind
    For Each cell In Range(xRgUni.Offset(1, 0), xRgUni.Worksheet.Cells(Rows.Count, xRgUni.Column).End(xlup))
    Gruß Daniel

    Betrifft: Danke ihr beiden -@Daniel - noch eine Frage
    von: Nilo
    Geschrieben am: 09.09.2020 10:50:41

    Deine Lösung B ist das was ich benötigte.
    Jetzt ist möchte ich die letzten beiden Zeilen nicht mit in die Liste nehmen

    Ich dachte das geht mit
  • Range(xRgUni.Offset(1, 0), xRgUni.Worksheet.Cells(Rows.Count, xRgUni.Column).End(xlUp).Row -2)

  • Aber dann zeigt er mir nichts mehr an?

    Betrifft: AW: Danke ihr beiden -@Daniel - noch eine Frage
    von: Daniel
    Geschrieben am: 09.09.2020 10:59:01

    Hi
    das mit dem ".Row-2" wäre korrekt, wenn den Zellbereich über die Adresse als Textstring erstellen würdest.
    hier gehen wir aber über zwei Zellen, daher dann:

    Range(xRgUni.Offset(1, 0), xRgUni.Worksheet.Cells(Rows.Count, xRgUni.Column).End(xlUp).Offset(-2, 0))

    Gruß Daniel

    Betrifft: aha, Danke :) owT
    von: Nilo
    Geschrieben am: 09.09.2020 11:42:28

    .

    Beiträge aus dem Excel-Forum zum Thema "Fill Listbox with Unique Values of Col"