Tip van de week: Vervolgkeuzelijst bij gegevensvalidatie in formulier

Marcel Kreijne - 06 Jun 2005

Ik ben op zoek naar een handige manier om mijn formulieren op te bouwen. Deze formulieren zijn op gewone werkbladen gebaseerd (dus niet op userforms in vba). De gebruiker moet steeds keuzes maken, waarbij een keuze in het ene veld keuzes in andere velden onmogelijk maakt. Hoe kan ik ervoor zorgen dat de gebruiker hierbij geholpen wordt door in de keuzelijstjes van gegevensvalidatie alleen de opties te tonen die (nog) mogelijk zijn?

Het eerste dat nodig is voor de oplossing van dit probleem is een tabel waarin ALLE mogelijke combinaties staan die de gebruiker zou kunnen kiezen. Kijk bijvoorbeeld naar de onderstaande tabel.

In deze tabel zijn alle keuzemogelijkheden vermeld in de kolommen Selectieveld1, Selectieveld2 en Selectieveld3. Heb je meer kolommen nodig, voeg dan net zo veel kolommen toe als je nodig hebt. Naast de kolommen die de kuezemogelijkheden vermelden staan ook nog twee kolommen met waarden die volgen uit een bepaalde keuze. Zorg ervoor dat de kolommen die de keuzemogelijkheden bepalen aaneengesloten naast elkaar staan in de tabel. Geef deze kolommen van de gegevenstabel een reeksnaam. In dit voorbeeld is gekozen voor de reeksnaam FilterData. Mocht je een andere naam willen kiezen, zorg dan dat je ook de naam in de macrocode aanpast (verderop).

De gehele gegevenstabel, dus inclusief de uit de selectie volgende waarden, krijgt ook een reeksnaam. In dit voorbeeld is dit de reeksnaam Data.

Voordat we aan het formulier beginnen, moeten er eerst op een "techniek werkblad" nog drie reeksnamen aangemaakt worden.

De basis is gelegd. Nu wordt het tijd om het formulier op te bouwen. In het voorbeeld wordt dit opnieuw op een nieuw werkblad gedaan, waardoor het bestand in het voorbeeld nu bestaat uit drie werkbladen. Het formulier kan bestaan uit kolommen met gegevens die niets met deze functionaliteit te maken hebben, selectieveld-kolommen en gevolgwaarde-kolommen. De gehele tabel krijgt een reeksnaam (van de kolomkoppen tot en met de laatste rij die bij de tabel hoort). In dit voorbeeld is de reeksnaam Formulier gebruikt. Bij het invoeren van de kolomkoppen van kolommen die niets met deze functionaliteit te maken heeft moet erop gelet worden dat deze NIET overeenkomen met de kolomkoppen in de gegevenstabel. Alle kolommen waarvan de kolomkop niet gevonden wordt in de gegevenstabel worden door de macro met rust gelaten.

Hieruit volgt dat de kolommen die WEL bij deze functionaliteit horen, de kolomkoppen moeten krijgen die overeen komt met de kop van de gewenste kolom in de gegevenstabel! In het formulier mogen (desgewenst) de niet-betrokken-kolommen, de selectieveld-kolommen en de gevolgwaarde-kolommen door elkaar staan. De macro herkent ze aan de kolomkoppen.

Oké, alle werkbladen staan klaar. Nu moet alleen de macrocode nog toegevoegd worden. Zet de onderstaande code in de werkbladcode van het werkblad waarop je het formulier hebt gebouwd:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Cells.Count <> 1 Then Exit Sub
    AutoFill Target

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    SetFilteredValidation Target
    
End Sub

Maak nu een module aan binnen het werkboek en plak er de onderstaande code in. Let erop dat je de waarden van de globale variabelen (de eerste paar regels van de onderstaande code) aan moet passen als je eerder in deze tip andere reeksnamen hebt gebruikt dan in de tip genoemd.

Option Explicit

Const MsCriteriaRange = "Criteria"
Const MsValidationListRange = "Filter"
Const MsAutoFillValidationListRange = "AutoFill"
Const MsDataRange = "Data"
Const MsAutoFillRange = "AutoFillData"
Const MsFormRange = "Formulier"
Const MbAutoFill = True

Sub SetFilteredValidation(Target As Range)
    
    '   (c) Copyright 2005 Quandan.
    '   Deze functie is afkomstig uit het vrij toegankelijke tips-archief van quandan.
    '
    '   Voor toepassing van deze functie binnen een bedrijf of instelling is een licentie vereist.
    '   Raadpleeg de website van quandan (www.quandan.nl) voor meer informatie of stuur een e-mail
    '   naar licentie@quandan.nl. Voor toepassing binnen liefdadigheids instellingen is een licentie
    '   aan te vragen als gift.

    Dim rCriteriaRange As Range
    Dim rDataRange As Range
    Dim rFormRange As Range
    Dim rValidationListRange As Range
    Dim rValidationListHeader As Range
    Dim rCell As Range
    Dim vCriteria As Variant
        
    If Target.Cells.Count > 1 Then Exit Sub
    
    Set rFormRange = ThisWorkbook.Names(MsFormRange).RefersToRange
    
    If Intersect(Target, rFormRange.Offset(1, 0).Resize(rFormRange.Rows.Count - 1)) Is Nothing Then Exit Sub

    Set rCriteriaRange = ThisWorkbook.Names(MsCriteriaRange).RefersToRange
    Set rDataRange = ThisWorkbook.Names(MsDataRange).RefersToRange
    Set rValidationListRange = ThisWorkbook.Names(MsValidationListRange).RefersToRange
    Set rValidationListHeader = rValidationListRange.Offset(-1, 0).Resize(1, 1)
    
    'Opbouwen filtercriteria
    vCriteria = qdBuildCriteria(rDataRange, rDataRange, rFormRange, _
    Target.Row - rFormRange.Row + 1, Target.Column - rDataRange.Column + 1)
    If IsEmpty(vCriteria) Then Exit Sub
    Set rCriteriaRange = rCriteriaRange.Resize(UBound(vCriteria, 1) - LBound(vCriteria, 1) + 1, _
    UBound(vCriteria, 2) - LBound(vCriteria, 2) + 1)
    rCriteriaRange = vCriteria
    rCriteriaRange.Name = MsCriteriaRange
    
    'Filteren van selectiemogelijkheden
    rValidationListRange.ClearContents
    rValidationListHeader.Value = rFormRange.Cells(1, Target.Column - rFormRange.Column + 1).Value
    rDataRange.AdvancedFilter xlFilterCopy, rCriteriaRange, rValidationListHeader, True
    Set rValidationListRange = rValidationListRange.CurrentRegion
    rValidationListRange.Sort Key1:=rValidationListRange.Cells(1, 1), _
    Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom
    rValidationListRange.Offset(1, 0).Resize(rValidationListRange.Rows.Count - 1, 1) _
    .Name = MsValidationListRange
    Set rValidationListRange = ThisWorkbook.Names(MsValidationListRange).RefersToRange
    
    'Instellen validatie
    rFormRange.Validation.Delete
    Target.Cells.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:="=" & MsValidationListRange
    
    If MbAutoFill Then
        If rValidationListRange.Rows.Count = 1 Then
            If Target.Value <> rValidationListRange.Value Then
                Target.Value = rValidationListRange.Value
            End If
        End If
    End If
    
End Sub

Sub AutoFill(Target As Range)
    
    '   (c) Copyright 2005 Quandan.
    '   Deze functie is afkomstig uit het vrij toegankelijke tips-archief van quandan.
    '
    '   Voor toepassing van deze functie binnen een bedrijf of instelling is een licentie vereist.
    '   Raadpleeg de website van quandan (www.quandan.nl) voor meer informatie of stuur een e-mail
    '   naar licentie@quandan.nl. Voor toepassing binnen liefdadigheids instellingen is een licentie
    '   aan te vragen als gift.
    
    Dim rCriteriaRange As Range
    Dim rDataRange As Range
    Dim rAutoFillRange As Range
    Dim rFormRange As Range
    Dim rValidationListRange As Range
    Dim rValidationListHeader As Range
    Dim rCell As Range
    Dim vCriteria As Variant
    Dim vTemp As Variant
    Static bSelfCalling As Boolean
    
    If bSelfCalling Then Exit Sub
    If Not MbAutoFill Then Exit Sub
    If Target.Rows.Count > 1 Then Exit Sub
    
    Set rFormRange = ThisWorkbook.Names(MsFormRange).RefersToRange
    
    If Intersect(Target, rFormRange.Offset(1, 0).Resize(rFormRange.Rows.Count - 1)) Is Nothing Then Exit Sub

    Set rCriteriaRange = ThisWorkbook.Names(MsCriteriaRange).RefersToRange
    Set rDataRange = ThisWorkbook.Names(MsDataRange).RefersToRange
    Set rAutoFillRange = ThisWorkbook.Names(MsAutoFillRange).RefersToRange
    Set rValidationListRange = ThisWorkbook.Names(MsAutoFillValidationListRange).RefersToRange
    Set rValidationListHeader = rValidationListRange.Offset(-1, 0).Resize(1, 1)
    
    On Error GoTo ExitFunction
    vTemp = WorksheetFunction.Match(rFormRange.Cells(1, Target.Column - rFormRange.Column + 1), rDataRange.Rows(1).Cells, 0)
    On Error Resume Next
    
    For Each rCell In rFormRange.Rows(Target.Row - rFormRange.Row + 1).Cells
        'Opbouwen filtercriteria
        vCriteria = qdBuildCriteria(rDataRange, rAutoFillRange, rFormRange, _
        rCell.Row - rFormRange.Row + 1, rCell.Column - rDataRange.Column + 1)
        If IsEmpty(vCriteria) Then GoTo SkipCell
        Set rCriteriaRange = rCriteriaRange.Resize(UBound(vCriteria, 1) - LBound(vCriteria, 1) + 1, _
        UBound(vCriteria, 2) - LBound(vCriteria, 2) + 1)
        rCriteriaRange = vCriteria
        rCriteriaRange.Name = MsCriteriaRange
        
        'Filteren van selectiemogelijkheden
        rValidationListRange.ClearContents
        rValidationListHeader.Value = rFormRange.Cells(1, rCell.Column - rFormRange.Column + 1).Value
        rAutoFillRange.AdvancedFilter xlFilterCopy, rCriteriaRange, rValidationListHeader, True
        Set rValidationListRange = rValidationListRange.CurrentRegion
        bSelfCalling = True
        If rValidationListRange.Rows.Count = 2 Then
            If Target.Value = "" Then
                'Do Nothing
            Else
                rCell.Value = rValidationListRange.Cells(2, 1).Value
            End If
        Else
            On Error Resume Next
            vTemp = "Error"
            vTemp = WorksheetFunction.Match(rFormRange.Cells(1, rCell.Column - rFormRange.Column + 1), rDataRange.Rows(1).Cells, 0)
            On Error GoTo SkipCell
            If Not IsNumeric(vTemp) Then
                rCell.ClearContents
            End If
        End If
        bSelfCalling = False
SkipCell:
    Next rCell
ExitFunction:

End Sub

Function qdBuildCriteria(rData As Range, rAutoFill As Range, rFilter As Range, _
lFilterRow As Long, iFilterCol As Integer) As Variant
    
    '   (c) Copyright 2005 Quandan.
    '   Deze functie is afkomstig uit het vrij toegankelijke tips-archief van quandan.
    '
    '   Voor toepassing van deze functie binnen een bedrijf of instelling is een licentie vereist.
    '   Raadpleeg de website van quandan (www.quandan.nl) voor meer informatie of stuur een e-mail
    '   naar licentie@quandan.nl. Voor toepassing binnen liefdadigheids instellingen is een licentie
    '   aan te vragen als gift.
    
    Dim vCriteria() As Variant
    Dim rCell As Range
    Dim vTemp As Variant
    
    On Error GoTo ExitFunction
    
    If WorksheetFunction.Match(rFilter.Cells(1, iFilterCol), rAutoFill.Rows(1).Cells, 0) Then
        ReDim vCriteria(1 To 2, 1 To 1)
        vCriteria(1, 1) = rFilter.Cells(1, iFilterCol).Value
        vCriteria(2, 1) = "<>0"
        
        For Each rCell In rFilter.Rows(1).Cells
            vTemp = "Error"
            On Error Resume Next
            vTemp = WorksheetFunction.Match(rFilter.Cells(1, rCell.Column - rFilter.Column + 1), _
            rData.Rows(1).Cells, 0)
            On Error GoTo 0
            If IsNumeric(vTemp) And rCell.Column - rFilter.Column + 1 <> iFilterCol And _
            Not rFilter.Cells(lFilterRow, rCell.Column - rFilter.Column + 1) = "" Then
                ReDim Preserve vCriteria(LBound(vCriteria, 1) To UBound(vCriteria, 1), LBound(vCriteria, 2) To UBound(vCriteria, 2) + 1)
                vCriteria(LBound(vCriteria, 1), UBound(vCriteria, 2)) = rFilter.Cells(1, rCell.Column - rFilter.Column + 1).Value
                vCriteria(UBound(vCriteria, 1), UBound(vCriteria, 2)) = rFilter.Cells(lFilterRow, rCell.Column - rFilter.Column + 1).Value
            End If
        Next
    End If
    
    qdBuildCriteria = vCriteria
ExitFunction:
    
End Function

Als alles nu goed gegaan is, wordt er door de macro een gegevensvalidatie ingesteld in de geselecteerde cel selecteert op het formulier onder een kolomkop die binnen de gegevenstabel FilterData valt.

Iedere selectie op een rij zorgt ervoor dat de selectiemogelijkheden van de overige selectiecellen beperkt wordt tot de overgebleven mogelijkheden. Als er uiteindelijk nog maar één mogelijkheid over is voor een bepaalde cel, zal die cel alvast gevuld worden, zoals in het onderstaande voorbeeld bij Selectieveld3, nadat in Selectieveld1 de waarde C gekozen is.

Is er in het geheel nog maar één mogelijkheid over, dan zullen ook de Gevolgwaarde-cellen gevuld worden door de macro. In het "slechtste" geval zal dit dus zijn nadat alle selectievelden ingevuld zijn. Zie onderstaande voorbeeld.

Mocht je problemen tegenkomen bij het toepassen van deze gecompliceerde tip, stuur even een mailtje en vergeet niet je bestand als bijlage toe te voegen. Deze code is op beperkte schaal getest, dus het zou kunnen dat er op andere machines nog problemen naar voren komen...

[ Bekijk het tip archief ] [ Een vraag stellen ]

Contactgegevens:
Balans 2
3823 GD AMERSFOORT
Tel. 06-28121462
Fax: 0842-204462
info@quandan.nl

Tip Top 5

Vervolgkeuzelijst bij gegevensvalidatie in formulier
Voorwaardelijk verbergen van rijen en kolommen
Dynamische navigatie met keuzelijst
Lijst van bestandsnamen en hyperlinks maken
Eenvoudige navigatie met keuzelijst