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.
- Maak een reeksnaam aan waar de validatielijst van een selectieveld kan komen te staan. Zorg ervoor dat er ten minste één regel boven leeg blijft. In dit voorbeeld de reeksnaam Filter.
- Maak een reeksnaam aan waar het filterresultaat van een gevolgwaardeveld kan komen te staan. Zorg er ook hier voor dat er ten minste één regel boven leeg blijft. In dit voorbeeld de reeksnaam AutoFill.
- Maak tot slot op dit werkblad nog een reeksnaam aan waar de filtercriteria opgebouwd kunnen worden. Boven deze reeksnaam hoeft geen rij leeg te blijven, hoewel dat in het onderstaande voorbeeld wel gebeurd is. In dit voorbeeld is het de reeksnaam Criteria geworden.
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 SubMaak 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 FunctionAls 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...
