Hilfe zu Combobox befüllen ausgeblendete Zeilen

Private Sub UserForm_Initialize() Dim dic As Object Dim xKey As Variant Dim iRow As Long, ALetzte As Long ALetzte = IIf(IsEmpty(Range("A65536")), Range("A65536").End(xlUp).Row, 65536) Set dic = CreateObject("scripting.dictionary") For iRow = 1 To ALetzte If Not IsEmpty(Cells(iRow, 1)) Then xKey = Cells(iRow, 1).Value dic(xKey) = 0 End If Next For Each xKey In dic ComboBox1.AddItem xKey Next dic.RemoveAll Set dic = Nothing Call Sortieren ComboBox1.ListIndex = 0 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Gerhard,
eine Möglichkeit.

' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************

Option Explicit

Dim bolOperate As Boolean

Private Sub UserForm_Initialize()
  fillCombo ComboBox1, Sheets("Tabelle1").UsedRange.Columns(1)
  ComboBox2.Enabled = False
  ComboBox3.Enabled = False
End Sub

Private Sub ComboBox1_Click()
  If bolOperate Then
    If ComboBox1.ListIndex > -1 Then
      fillCombo ComboBox2, Sheets("Tabelle1").UsedRange.Columns(2)
      ComboBox2.Enabled = True
    End If
  End If
End Sub

Private Sub ComboBox2_Click()
  If bolOperate Then
    If ComboBox2.ListIndex > -1 Then
      fillCombo ComboBox3, Sheets("Tabelle1").UsedRange.Columns(3)
      ComboBox3.Enabled = True
    End If
  End If
End Sub

Private Sub fillCombo(ByRef CBO As ComboBox, Target As Range, Optional VisibleCellsOnly As Boolean = True)
  Dim objDic As Object
  Dim vntKey As Variant, vntTmp() As Variant
  Dim rng As Range, rngList As Range

  On Error Resume Next

  bolOperate = False

  Set objDic = CreateObject("scripting.dictionary")
  If VisibleCellsOnly Then
    Set rngList = Target.SpecialCells(xlCellTypeVisible)
  Else
    Set rngList = Target.SpecialCells(xlCellTypeConstants)
    If rngList Is Nothing Then
      Set rngList = Target.SpecialCells(xlCellTypeFormulas)
    Else
      Set rngList = Union(rngList, Target.SpecialCells(xlCellTypeFormulas))
    End If
  End If

  On Error GoTo 0

  If Not rngList Is Nothing Then
    For Each rng In rngList
      If Not IsEmpty(rng) Then
        vntKey = rng.Value
        objDic(vntKey) = 0
      End If
    Next

    vntTmp = objDic.keys

    QuickSort vntTmp

    CBO.Clear
    CBO.List = vntTmp
    CBO.ListIndex = 0
    objDic.RemoveAll
  End If

  bolOperate = True

  Set objDic = Nothing
  Set rng = Nothing
  Set rngList = Nothing
End Sub

Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
  Dim P1&, P2&, T1 As Variant, T2 As Variant

  UG = IIf(IsMissing(UG), LBound(data), UG)
  OG = IIf(IsMissing(OG), UBound(data), OG)

  P1 = UG
  P2 = OG
  T1 = data((P1 + P2) / 2)

  Do

    Do While (data(P1) < T1)
      P1 = P1 + 1
    Loop

    Do While (data(P2) > T1)
      P2 = P2 - 1
    Loop

    If P1 <= P2 Then
      T2 = data(P1)
      data(P1) = data(P2)
      data(P2) = T2
      P1 = P1 + 1
      P2 = P2 - 1
    End If

  Loop Until (P1 > P2)

  If UG < P2 Then QuickSort data, UG, P2
  If P1 < OG Then QuickSort data, P1, OG

End Sub

Gruß Sepp

Hallo Sepp...
Nochmals vielen Dank für deine Hilfe.
Was mir nun schwierigkeiten macht, ist das setzen der Autofilter.
Wenn ich unten angepassten Code so laufen lasse, setzt dieser mir sofort einen Autfilter in Splate 1 bevor ich überhaupt etwas aufgerufen habe.
Option Explicit
Dim bolOperate As Boolean

Private Sub UserForm_Initialize()
fillCombo CBO_BEZEICHNUNG, Sheets("Übersicht Datenbank").UsedRange.Columns(1)
CBO_GROESSE_EINS.Enabled = False
CBO_GROESSE_ZWEI.Enabled = False
End Sub

Private Sub CBO_BEZEICHNUNG_click()
If bolOperate Then
If CBO_BEZEICHNUNG.ListIndex > -1 Then
fillCombo CBO_GROESSE_EINS, Sheets("Übersicht Datenbank").UsedRange.Columns(2)
CBO_GROESSE_EINS.Enabled = True
End If
End If
'Nach diesem Auswählen eines Wertes, soll in Sheet Übersicht Datenbank ein Autofilter gesetzt  _
werden.
Worksheets("Übersicht Datenbank").Select
Selection.AutoFilter Field:=1, Criteria1:=CBO_BEZEICHNUNG.Value
End Sub

'Dann soll diese Combobox befüllt werden mit den nun sichtbaren Zeilen


Private Sub CBO_GROESSE_EINS_click()
If bolOperate Then
If CBO_GROESSE_EINS.ListIndex > -1 Then
fillCombo CBO_GROESSE_ZWEI, Sheets("Übersicht Datenbank").UsedRange.Columns(3)
CBO_GROESSE_ZWEI.Enabled = True
End If
End If
'Nach diesem Auswählen eines Wertes, soll in Sheet Übersicht Datenbank ein Autofilter gesetzt  _
werden.
Worksheets("Übersicht Datenbank").Select
Selection.AutoFilter Field:=2, Criteria1:=CBO_GROESSE_EINS.Value
End Sub

'Dann soll die dritte und letzte Combobox mit den noch sichtbaren Zeilen befüllt werden und nach Auswahl ebenfalls ein Autofilter mit dem Wert gesetzt werden.

Private Sub fillCombo(ByRef CBO As ComboBox, Target As Range, Optional VisibleCellsOnly As  _
Boolean = True)
Dim objDic As Object
Dim vntKey As Variant, vntTmp() As Variant
Dim rng As Range, rngList As Range
On Error Resume Next
bolOperate = False
Set objDic = CreateObject("scripting.dictionary")
If VisibleCellsOnly Then
Set rngList = Target.SpecialCells(xlCellTypeVisible)
Else
Set rngList = Target.SpecialCells(xlCellTypeConstants)
If rngList Is Nothing Then
Set rngList = Target.SpecialCells(xlCellTypeFormulas)
Else
Set rngList = Union(rngList, Target.SpecialCells(xlCellTypeFormulas))
End If
End If
On Error GoTo 0
If Not rngList Is Nothing Then
For Each rng In rngList
If Not IsEmpty(rng) Then
vntKey = rng.Value
objDic(vntKey) = 0
End If
Next
vntTmp = objDic.keys
QuickSort vntTmp
CBO.Clear
CBO.List = vntTmp
CBO.ListIndex = 0
objDic.RemoveAll
End If
bolOperate = True
Set objDic = Nothing
Set rng = Nothing
Set rngList = Nothing
End Sub

Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1)  T1)
P2 = P2 - 1
Loop
If P1  P2)
If UG

Könntest du nochmals drüber schauen?
Wäre suuuuper
Vielen Dank und gute Nacht...
Gruß Gerhard

Beliebteste Forumthreads (12 Monate)

Hilfe zu Combobox befüllen ausgeblendete Zeilen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Hilfe zu Combobox befüllen ausgeblendete Zeilen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread