comboboxen filteren keus 1, keus 2, keus 3

Andre175 · 24 sep 2018

goedenavond allen

ik kom er ff niet (helemaal) uit hoe ik de 2e en 3e combobox kan filteren na keuze van de 1e combobox.
Van de site van SNB staat een duidelijk voorbeeld wat ook werkt, echter heb ik de eerste kolom van mijn tabel uitgebeid met een ID nummer.

nu gaat het mis, de eerste combobox gaat goed, maar vervolgens komt er niets in de 2e en 3e combobox.
Ik heb al het 1 en ander geprobeerd maar weet niet wat ik nu precies moet aanpassen in de code.

CB1 = keuze opdrachtgever Kolom B in de tabel
CB2 = keuze ritnummer Kolom C
CB3 = keuze zendingnummer Kolom D

waar moet ik de code aanpassen en graag een kleine uitleg erbij zodat ik het weet waarom.

(Het gaat um de userform "MAINFORM" in het bestand. Userform "MULTIPAGE" is niet van belang)

Code:

Private Sub UserForm_Initialize()

'###############################
'## PAGE: INVOER              ##
'###############################

    CB4.List = Split("Laden |Lossen |Overig ", "|")
    

     sn = Sheets("invoer").Cells(1).CurrentRegion
        For j = 2 To UBound(sn)
           If InStr(c01 & ",", "," & sn(j, 2) & ",") = 0 Then c01 = c01 & "," & sn(j, 2)
        Next
        CB1.List = Split(Mid(c01, 2), ",")
        CB2.Clear
        CB3.Clear
        
        
'###############################
'## PAGE: Debiteuren          ##
'###############################

'        TBK01.Value = WorksheetFunction.Max([IDsSch]) + 1
        With ListBDeb
            .ColumnHeads = False
            .List = [Tbl_Debiteuren].Value
            .ColumnCount = [Tbl_Debiteuren].CurrentRegion.Columns.Count
            .ColumnWidths = "20;70;70;30;70;70;70;0;0;0;0;0"
        End With
        
    sn = Sheets("Debiteuren").Cells(1).CurrentRegion
    For j = 1 To 12 'UBound(sn, 2)
         Me("Lbd" & Format(j, "00")).Caption = sn(1, j)
    Next
        
'###############################
'## PAGE: KLANTEN             ##
'###############################

'        TBK01.Value = WorksheetFunction.Max([IDsSch]) + 1
        With ListBklant
            .ColumnHeads = False
            .List = [Tbl_KLANTEN].Value
            .ColumnCount = [Tbl_KLANTEN].CurrentRegion.Columns.Count
            .ColumnWidths = "20;70;70;30;70;70;70;0;0;0"
        End With
        
    sn = Sheets("klanten").Cells(1).CurrentRegion
    For j = 1 To 10 'UBound(sn, 2)
         Me("Lbk" & Format(j, "00")).Caption = sn(1, j)
    Next

End Sub

Private Sub CB1_Change()
  
    CB2.ListIndex = -1
    CB3.ListIndex = -1
    If CB1.ListIndex > -1 Then CB2.List = Split(lijst(2), ",")

    With Sheets("debiteuren")
        For i = 2 To .Range("C" & Rows.Count).End(xlUp).Row
            If .Cells(i, 3) = CB1.List(CB1.ListIndex, 0) Then
                For j = 4 To 13
                Me("L_" & Format(j, "000")).Caption = .Cells(i, j).Value
                Me("L_002").Caption = .Cells(i, 2).Value
                Next j
            End If
        Next
    End With
  
End Sub

Private Sub CB2_Change()
    If CB2.ListIndex > -1 Then CB3.List = Split(lijst(2), ",")
End Sub

Private Sub CB3_Change()

    If CB3.ListIndex = -1 Then Exit Sub
    
    c01 = CB1.Value & CB2.Value & CB3.Value & CB4.Value
    For j = 2 To UBound(sn)
        If sn(j, 1) & sn(j, 2) & sn(j, 3) & sn(j, 4) = c01 Then Exit For
    Next
     
    For jj = 1 To 15
            Me("TB" & jj).Value = sn(j, jj + 5)
    Next
    
   
  
End Sub

Bekijk bijlage 2018 test2.xlsb

bvd André

ExcelAmateur · 24 sep 2018

Heb je de code ook met F8 doorlopen om te zien waar het mis gaat?
Niet dat ik het zo snel weet, kan het niet op de IPad doen.

Andre175 · 24 sep 2018

Cb2 en Cb3 blijven leeg.
het formulier geeft verder geen foutmelding

HSV · 24 sep 2018

Helaas krijg ik hele rare meldingen van jouw bestand.

Het principe:

Code:

Private Sub UserForm_Initialize()
Dim sv, i As Long
sv = Sheets(1).Cells(1).CurrentRegion
   Set Dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(sv)
      If Not Dic.exists(sv(i, 1)) Then Dic.Item(sv(i, 1)) = Array(sv(i, 1), CreateObject("scripting.dictionary"))
        Dic(sv(i, 1))(1).Item(sv(i, 2)) = Dic(sv(i, 1))(1).Item(sv(i, 2)) & " " & sv(i, 3)
    Next i
 ComboBox1.List = Dic.keys
End Sub


Private Sub ComboBox1_Change()
 ComboBox2.List = Dic(ComboBox1.Value)(1).keys
 ComboBox2.ListIndex = -1
End Sub


Private Sub ComboBox2_Change()
  ComboBox3.List = Split(Trim(Dic(ComboBox1.Value)(1)(ComboBox2.Value)))
End Sub

Andre175 · 24 sep 2018

Hallo Harry.

mijn excuses voor de rare meldingen..... ik zie dat er nog 2 verbindingen in staan naar een ander bestand. (Query's en Verbindingen)
deze horen er niet in thuis.

Ik zie dat jij het weer op een geheel andere manier doet als het voorbeeld dat ik van de site van SNB heb.
http://www.snb-vba.eu/VBA_Afhankelijke_Comboboxen.html#L_2

ik zal nog een poging doen het bestand zonder rare meldingen te plaatsen.

de bedoeling is dus dat CB1 de gegevens haalt uit kolom B
CB2 de gegevens uit kolom C
CB3 de gevevens uit kolom D

rij 1 zijn titels van de tabel, dus vanaf rij 2 moet in de comboboxen

Code:

Private Sub UserForm_Initialize()
Dim sv, i As Long
sv = Sheets(1).Cells(1).CurrentRegion
   Set Dic = CreateObject("scripting.dictionary")
    For i = [COLOR="#FF0000"]2 [/COLOR]To UBound(sv)
      If Not Dic.exists(sv(i, [COLOR="#00FF00"]2[/COLOR])) Then Dic.Item(sv(i, [COLOR="#00FF00"]2[/COLOR])) = Array(sv(i, [COLOR="#00FF00"]2[/COLOR]), CreateObject("scripting.dictionary"))
        Dic(sv(i, 1))(1).Item(sv(i, 2)) = Dic(sv(i, 1))(1).Item(sv(i, 2)) & " " & sv(i, 3)
    Next i
 ComboBox1.List = Dic.keys
End Sub


Private Sub ComboBox1_Change()
 ComboBox2.List = Dic(ComboBox1.Value)(1).keys
 ComboBox2.ListIndex = -1
End Sub


Private Sub ComboBox2_Change()
  ComboBox3.List = Split(Trim(Dic(ComboBox1.Value)(1)(ComboBox2.Value)))
End Sub

Ben ik zo op de goede weg???

Bekijk bijlage 2018 test2.xlsb

bestand opnieuw geupload, nu goed hoop ik.

HSV · 24 sep 2018

Helaas, de melding blijft of ik het wil herstellen.
Blad invoer is leeg; klopt dat?

Je bent op de goede weg.
De andere regel ook nog.

Andre175 · 24 sep 2018

Blad invoer is niet leeg.
daar staat de tabel waar ik de gegevens voor de comboboxen uit haal.

Ik heb geprobeerd om in #5 het bestand opnieuw erin te zetten, nu zie ik dat er 2 koppelingen in staan, 2 verschillende bestanden.
het 2e bestand kan ik niet verwijderen, deze is niet zichtbaar als ik #5 wil aanpassen.

vandaar hier dan nog maar eens een keer.

Bekijk bijlage 2018 test2.xlsb

nu moet het toch echt goed gaan.

Andre175 · 24 sep 2018

Code:

Private Sub UserForm_Initialize()
Dim sv, i As Long
sv = Sheets(1).Cells(1).CurrentRegion
   Set Dic = CreateObject("scripting.dictionary")
    For i = [COLOR="#FF0000"]2 [/COLOR]To UBound(sv)
      If Not Dic.exists(sv(i, [COLOR="#FF0000"]2[/COLOR])) Then Dic.Item(sv(i, [COLOR="#FF0000"]2[/COLOR])) = Array(sv(i, [COLOR="#FF0000"]2[/COLOR]), CreateObject("scripting.dictionary"))
        Dic(sv(i, [COLOR="#FF0000"]2[/COLOR]))(1).Item(sv(i, [COLOR="#FF0000"]3[/COLOR])) = Dic(sv(i, [COLOR="#FF0000"]2[/COLOR]))(1).Item(sv(i, [COLOR="#FF0000"]3[/COLOR])) & " " & sv(i, [COLOR="#FF0000"]4[/COLOR])
    Next i
 ComboBox1.List = Dic.keys
End Sub


Private Sub ComboBox1_Change()
 ComboBox2.List = Dic(ComboBox1.Value)(1).keys
 ComboBox2.ListIndex = -1
End Sub


Private Sub ComboBox2_Change()
  ComboBox3.List = Split(Trim(Dic(ComboBox1.Value)(1)(ComboBox2.Value)))
End Sub

om eerlijk te zijn blijft het een gok voor me, of ik het zo juist aangepast heb.
zal het morgen gaan proberen.

weltrusten en tot morgen

emields · 24 sep 2018

Kan het bestand ook niet openen. met wat is dat gemaakt?

Andre175 · 25 sep 2018

Goedemorgen

op mijn telefoon kan ik het bestand ook niet openen, op mijn laptop wel.
Het is gewoon met excel 2016 (office 365 abonnement) gemaakt.

Code:

Private Sub UserForm_Initialize()
Dim sv, i As Long
sv = Sheets("invoer").Cells(1).CurrentRegion
   Set Dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sv)
      If Not Dic.exists(sv(i, 2)) Then Dic.Item(sv(i, 2)) = Array(sv(i, 2), CreateObject("scripting.dictionary"))
        Dic(sv(i, 2))(1).Item(sv(i, 3)) = Dic(sv(i, 2))(1).Item(sv(i, 3)) & " " & sv(i, 4)
    Next i
 CB1.List = Dic.keys
End Sub


Private Sub CB1_Change()
 [COLOR="#FF0000"]CB2.List = Dic(CB1.Value)(1).keys[/COLOR]
 CB2.ListIndex = -1
End Sub


Private Sub CB2_Change()
  CB3.List = Split(Trim(Dic(CB1.Value)(1)(CB2.Value)))
End Sub

Harry, ik heb dit zo geprobeerd, echter krijg ik hier de melding sub of function niet gedefinieerd als ik met F8 de code doorloop.
Blijft hangen bij de rood gemarkeerde tekst zodra ik een keuze maak met de eerste combobox, CB1.

heb een "schoon" bestand gemaakt....

Bekijk bijlage keuze123.xlsm

André

sylvester-ponte · 25 sep 2018

zet bovenaan in de module eens
Dim dic

Andre175 · 25 sep 2018

goedemiddag

ik ben aan het puzzelen geweest met beide codes, die van SNB en die van Harry (HSV).
Met beide codes is het me gelukt om de comboboxen met de juiste gegevens te voorzien, zowel zonder en met een 1e kolom met ID nummers.

Bij de code van Harry weet ik nog niet hoe het resultaat in de textboxen te krijgen.

onderstaande code (met dank aan SNB) werkt voor de situatie met in kolom A een ID nummering.

Code:

Dim sn

Private Sub UserForm_Initialize()
    [COLOR="#FF0000"]sn = Sheets("form4").Range("b1:g14")[/COLOR]
    For j = 2 To UBound(sn)
        If InStr(c01 & ",", "," & sn(j, 1) & ",") = 0 Then c01 = c01 & "," & sn(j, 1)
    Next
    
    CB1.List = Split(Mid(c01, 2), ",")
    CB2.Clear
    CB3.Clear
End Sub

Private Sub CB1_Change()
    CB2.ListIndex = -1
    CB3.ListIndex = -1
    If CB1.ListIndex > -1 Then CB2.List = Split(lijst(1), ",")
End Sub
Private Sub CB2_Change()
    If CB2.ListIndex > -1 Then CB3.List = Split(lijst(2), ",")
End Sub
Function lijst(x)
    For j = 1 To UBound(sn)
        For jj = 1 To x
            If sn(j, jj) <> Me("CB" & jj).Value Then Exit For
        Next
        If jj = x + 1 And InStr(c01 & ",", "," & sn(j, jj) & ",") = 0 Then c01 = c01 & "," & sn(j, jj)
    Next
    lijst = Mid(c01, 2)
End Function


Private Sub CB3_Change()
    If CB3.ListIndex = -1 Then Exit Sub
    
    c01 = CB1.Value & CB2.Value & CB3.Value
    For j = 1 To UBound(sn)
        If sn(j, 1) & sn(j, 2) & sn(j, 3) = c01 Then Exit For
    Next

Maar de tabel zal steeds langer worden, dus dan klopt de array sn niet meer.
maak ik de code voor sn als hieronder, dan loopt excel vast.

Code:

Private Sub UserForm_Initialize()
   [COLOR="#FF0000"] sn = Sheets("form4").Columns("B:G")[/COLOR]
    For j = 2 To UBound(sn)
        If InStr(c01 & ",", "," & sn(j, 1) & ",") = 0 Then c01 = c01 & "," & sn(j, 1)
    Next
    
    CB1.List = Split(Mid(c01, 2), ",")
    CB2.Clear
    CB3.Clear
End Sub

Dus je vraag is: Hoe declareer ik de array sn in bovenstaande code zodat de lengte van de tabel niet uitmaakt, en hoe vul ik de textboxen als ik de eerste code (code van harry) gebruik?

Bekijk bijlage keuze123.xlsm

het bestand bevat 4 tabbladen
tab 1 - tabel zonder ID nummers - code harry
tab 2 - tabel zonder ID nummers - code SNB
tab 3 - tabel met ID nummers - code harry
tab 4 - tabel met ID nummers - code SNB

Haije · 25 sep 2018

Andre,

probeer eens

Code:

sn = Sheets("form4").Range("b1").CurrentRegion

Andre175 · 25 sep 2018

helaas Haije....

Ok nu komen de waarden uit kolom A voor CB1 ipv van de waarden uit kolom A

Haije · 25 sep 2018

deze dan:

Code:

sn = Sheets("form4").Range("b1").CurrentRegion.Offset(, 1).Resize(, 6)

Andre175 · 25 sep 2018

Yes....

Zo gaat ie goed.

Aangezien de code van Harry behoorlijk korter is....
Weet je (of weet iemand) hoe ik het resultaat in de 3 textboxen kan krijgen nadat de keuze's gemaakt zijn?

Code:

Dim dic
Private Sub UserForm_Initialize()
Dim sv, i As Long

sv = Sheets("form3").Cells(1).CurrentRegion
   Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sv)
      If Not dic.exists(sv(i, 2)) Then dic.Item(sv(i, 2)) = Array(sv(i, 2), CreateObject("scripting.dictionary"))
        dic(sv(i, 2))(1).Item(sv(i, 3)) = dic(sv(i, 2))(1).Item(sv(i, 3)) & " " & sv(i, 4)
    Next i
 CB1.List = dic.keys
End Sub


Private Sub CB1_Change()
 CB2.List = dic(CB1.Value)(1).keys
 CB2.ListIndex = -1
End Sub


Private Sub CB2_Change()
  CB3.List = Split(Trim(dic(CB1.Value)(1)(CB2.Value)))
End Sub


Private Sub CB3_Change()
[COLOR="#FF0000"]'tekst uit kolom E in TB1
'tekst uit kolom F in TB2
'tekst uit kolom G in TB3[/COLOR]
End Sub

HSV · 25 sep 2018

Het bestand in de bijlage is er speciaal voor geknipt.
Daar kom je vast wel uit.

Andre175 · 26 sep 2018

goedenavond....

Ik had gehoopt dat je gelijk had Harry, maar helaas.
ik ben al wel een stuk verder ,maar loop toch nog tegen wat problemen aan.

met name de 3e combobox. Daar verdwijnt de 1e waarde uit de tabel.
En als in de tabel iets staat met een spatie ertussen, dan wordt dit in de combobox weergegeven als 2 keuze's.
Staat er bijvoorbeeld "Zending 1" "Zending 2", "Zending 3".....enz, dan geeft de combobox "Zending", "1", Zending", "2", "Zending", "3"....enz weer.

Bekijk bijlage keuze123.xlsm

het gaat hier om tabblad "form3" en dus de code in userform 3

HSV · 27 sep 2018

Maak van de spatie in de code een pipe.
& "|" &
En dan doe bij de Change hetzelfde.
Cb3.list=split(trim(........),"|")

snb · 27 sep 2018

De macro gaat ervan uit dat een selectie wordt gemaakt op basis van de eerste 3 kolommen van de tabel.
Als je een ID gaat toevoegen als eerste kolom gaat de macro daarom natuurlijk niet werken.
Dan zul je het een en ander aan de macro moeten aanpassen.
De huidige macro is alleen geschikt voor werkblad 1 en 2 (zonder toegevoegde ID-kolom)

Je hebt maar 1 Userform nodig.
Je hebt maar 1 startmacro nodig die je aan alle vier knoppen kunt hangen.
Ik heb de macro aangepast, zodat de toegevoegde ID-kolom geen probleem meer vormt.

comboboxen filteren keus 1, keus 2, keus 3

Gebruiker

Terugkerende gebruiker

Gebruiker

Inventaris

Gebruiker

Bijlagen

Inventaris

Gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Verenigingslid

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Inventaris

Bijlagen

Gebruiker

Inventaris

Verenigingslid

Bijlagen

Wij waarderen jouw privacy