Excel bestand maken - selectie d.m.v. combinaties van keuzelijsten met invoervakken

Status
Niet open voor verdere reacties.
J

jhdw

Gebruiker
Lid geworden
15 dec 2012
Berichten
166
Hallo access experts,
Weer een uitdaging, ik hoop dat iemand hiermee kan/wil helpen. In de dB heb ik in de koptekst op een doorlopend formulier 6 keuzelijsten met invoervak waarmee ik gegevens wil filteren. De volgorde (voor het gemak van links naar rechts) is: kzl_zk_dealer, kzl_zk_manager, kzl_zk_merk, kzl_zk_afdeling, kzl_zk_functie en kzl_zk_medewerker.
De merken zijn ondergebracht in 2 groepen. In een groepsvak heb ik 3 keuzemogelijkheden: alle merken, groep A of groep B. De dealers kunnen zowel merken uit groep A als groep B vertegenwoordigen, datzelfde geldt voor de managers.
Een dealer vertegenwoordigd één of meerdere merken. Een manager is verantwoordelijk voor bepaalde merken in een beperkt gebied. Bij een dealer heb je afdelingen zoals bijv. algemeen, sales en after sales. Onder afdelingen vallen dan weer functies: bijv. onder sales valt verkoop en marketing en onder after sales valt werkplaats en magazijn.
Het is de bedoeling dat ik op allerlei combinaties kan filteren. Als ik bijv. groep A heb gekozen, dan kan ik alleen de dealers kiezen die daar onder vallen en de managers die voor die groep bij die dealers komen. Allerlei combinaties zijn mogelijk met dien verstande dat ik altijd vanaf links wil beginnen met een keuze. Als ik manager kies en geen merk dan kan ik in afdeling alle afdelingen kiezen die bij die manager horen.
Uiteindelijk wil ik van de selectie een Excel bestand kunnen maken en omdat er zoveel combinaties mogelijk zijn, zit daar mijn probleem. Ik heb wel een code gemaakt maar die is zo gecompliceerd dat ik denk dat het wel eenvoudiger zou moeten kunnen. Wie heeft er een beter idee?
Code: 
 Option Compare Database
Option Explicit
Dim qTmp As QueryDef
Dim strSQL As String
Dim ctl As Control
Dim itm As Variant
Dim sFilter As String, sFilterDealer As String, sFilterManager As String, sFilterMerk As String, sFilterAfdeling As String, sFilterFunctie As String, sFilterMedewerker As String

Private Sub cmd_excel_Click()
   
   On Error GoTo cmd_excel_Click_Error

        With Me
            strSQL = "SELECT tbl_dealer.DKOD_Factuur, tbl_dealer.DKOD_Aflever, tbl_dealer.Bedrijf, tbl_dealer.Adres, tbl_dealer.[Postcode adres], tbl_dealer.[Plaats adres], tbl_manager.Rayonmanager, tbl_manager.E_mail_mng, tbl_merken.Merk, tbl_soort_dealer.Soort, tbl_afdelingen.Afdeling, tbl_dealer_afd_email.E_mail_afd, tbl_functie.Functie, tbl_medewerkers.Vr_medewerker, tbl_medewerkers.Tn_medewerker, tbl_medewerkers.Am_medewerker, tbl_medewerkers.Telefoon, tbl_medewerkers.E_mail_mdw "
            strSQL = strSQL & "FROM tbl_merken INNER JOIN (tbl_medewerkers INNER JOIN ((tbl_dealer INNER JOIN (((tbl_afdelingen INNER JOIN ((tbl_afdeling_functie INNER JOIN tbl_manager ON tbl_afdeling_functie.Manager_ID = tbl_manager.ID_manager) INNER JOIN tbl_soort_dealer ON tbl_afdeling_functie.Soort_ID = tbl_soort_dealer.ID_soort_dealer) ON tbl_afdelingen.ID_afdeling = tbl_afdeling_functie.Afdeling_ID) INNER JOIN tbl_dealer_afd_email ON tbl_afdelingen.ID_afdeling = tbl_dealer_afd_email.Afdeling_ID) INNER JOIN tbl_functie ON (tbl_functie.ID_functie = tbl_afdeling_functie.Functie_ID) "
            strSQL = strSQL & "AND (tbl_afdelingen.ID_afdeling = tbl_functie.Afdeling_ID)) ON (tbl_dealer.ID_dealer = tbl_dealer_afd_email.Dealer_ID) "
            strSQL = strSQL & "AND (tbl_dealer.ID_dealer = tbl_afdeling_functie.Dealer_ID)) INNER JOIN tbl_dealer_medewerker ON tbl_dealer.ID_dealer = tbl_dealer_medewerker.Dealer_ID) ON (tbl_medewerkers.ID_medewerker_dealer = tbl_dealer_medewerker.Medewerker_ID) "
            strSQL = strSQL & "AND (tbl_medewerkers.ID_medewerker_dealer = tbl_afdeling_functie.Medewerker_ID)) ON tbl_merken.ID_merk = tbl_afdeling_functie.Merk_ID "
            
            If Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling <> vbNullString And Not .kzl_zk_functie <> vbNullString Then
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer <> vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager <> vbNullString And Not .kzl_zk_merk = vbNullString And Not .kzl_zk_afdeling <> vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Merk_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_merk]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            ElseIf Not .kzl_zk_dealer = vbNullString And Not .kzl_zk_manager = vbNullString And Not .kzl_zk_merk <> vbNullString And Not .kzl_zk_afdeling = vbNullString And (Not .kzl_zk_functie <> vbNullString Or Not .kzl_zk_functie = vbNullString) And (Not .kzl_zk_medewerker <> vbNullString Or Not .kzl_zk_medewerker = vbNullString) Then
                strSQL = strSQL & "WHERE(((tbl_afdeling_functie.Dealer_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_dealer]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Manager_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_manager]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Afdeling_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_afdeling]) "
                strSQL = strSQL & "And ((tbl_afdeling_functie.Functie_ID) = [Formulieren]![frm_invoer_gegevens]![kzl_zk_functie])"
            End If
            strSQL = strSQL & "GROUP BY tbl_dealer.DKOD_Factuur, tbl_dealer.DKOD_Aflever, tbl_dealer.Bedrijf, tbl_dealer.Adres, tbl_dealer.[Postcode adres], tbl_dealer.[Plaats adres], tbl_manager.Rayonmanager, tbl_manager.E_mail_mng, tbl_merken.Merk, tbl_soort_dealer.Soort, tbl_afdelingen.Afdeling, tbl_dealer_afd_email.E_mail_afd, tbl_functie.Functie, tbl_medewerkers.Vr_medewerker, tbl_medewerkers.Tn_medewerker, tbl_medewerkers.Am_medewerker, tbl_medewerkers.Telefoon, tbl_medewerkers.E_mail_mdw;"
            Set qTmp = CurrentDb.QueryDefs("qry_medewerkers_gekoppeld")
            qTmp.SQL = strSQL
            DoCmd.OutputTo acOutputQuery, "qry_medewerkers_gekoppeld", "ExcelWorkbook(*.xlsx)", "Selectie.xlsx", True, "", , acExportQualityScreen
        End With

   On Error GoTo 0
   Exit Sub

cmd_excel_Click_Error:

      Select Case Err.Number
        Case 2302
            Call MsgBox("Je hebt nog een Excel bestand open staan." _
                        & vbCrLf & "" _
                        & vbCrLf & "Deze eerst afsluiten." _
                        , vbInformation, Application.Name)
      End Select

'    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmd_excel_Click of VBA Document Form_frm_invoer_gegevens"
End Sub

Alvast bedantk voor de hulp

Gr. Jan
 
Begin eens met deze code weg te gooien (je hebt gelijk: veuls te gecompliceerd) en een filter te bouwen op basis van wat er is gekozen. Ik maak heel wat gecompliceerdere filterschermen, maar daar zit niet de helft van jouw code in :).
 
Om je een beetje op weg te helpen, hier een functie die ik zelf gebruik. Je zult hem niet gelijk kunnen toepassen denk ik, omdat je ook het e.e.a. in je zoekformulier zult moeten aanpassen. Zo maak ik gebruik van vaste namen voor de keuzelijsten. Eigenlijk ben ik daar dan een beetje lui in, want ik gebruik vaak de namen die Access zelf toekent aan nieuwe objecten. Of andere standaardnamen. Een keuzelijst (al dan niet met invoervak) heet bij Access altijd Keuzelijst###, wat niet handig is omdat in een gewone keuzelijst meerdere waarden geselecteerd kunnen worden en in een keuzelijst met invoervak altijd maar één. Toch is zo'n object nog wel uit te lezen op type. En dat is wat ik dus dan doe: ik gebruik de objecten op een formulier en bekijk of ze zijn ingevuld of niet. In het eerste geval wordt het object toegevoegd aan het filter, anders niet.

Om dat uitlezen zo simpel mogelijk te maken, heb je dus standaardnamen nodig, vandaar dat ik die vaak laat staan en alleen bekijk of de naam voldoet aan mijn zoekinstellingen. Daarnaast gebruik ik de <Extra Info> (<Tag>) van de zoekobjecten om te bepalen wat er gezocht moet worden. Elk zoekobject is op die manier gekoppeld aan het veld waarin gezocht wordt. En dat maakt het zoekformulier uiterst flexibel, want ik hoef aan mijn functie nooit iets te veranderen als er zoekvelden bijkomen of weg moeten. Ik voeg ze toe, vul de juiste gegevens in en alles blijft werken.
Hier dus die functie:

Code: 
Function CheckFilter(frm As Form) As String
Dim sFilter As String, sFilters() As String, sTekst() As String
Dim sAndOr As StringsKeuze As String
Dim sC As Variant, sD As String
Dim ctl As Control, lst As Access.ListBox
Dim itm As Variant, tmpMatrix As Variant, tmp As Variant
Dim rst As Recordset
Dim iFltr As Integer, iLst As Integer
Dim bDatum As Boolean, bPc As Boolean
Dim chk As Double
'Dim itm As String
Const strcJetDate = "\#mm\/dd\/yyyy\#"  'Do NOT change it to match your local settings.

    '-----------------------------------------------------------------------------------------------------------
    'Eerst de grootte van de matrix bepalen....
    'Dat doen we door alle filters door te lopen, en de inhoud in een matrix te zetten.
    'We lopen door de controls heen op basis van het ControlType.
    '-----------------------------------------------------------------------------------------------------------
    x = 0:    iFltr = 0:    iLst = 0
    
    For Each ctl In frm.Controls
        With ctl
            ''On Error Resume Next
            Select Case .ControlType
                Case acTextBox
                    If LCase(Left(.Name, 8)) = "tekstvak" Then
                        iFltr = iFltr + 1
                        On Error Resume Next
                        If Not .Value = "" Then
                            x = x + 1
                            If x = 1 Then
                                ReDim sTekst(x)
                            Else
                                ReDim Preserve sTekst(x)
                            End If
                            sTekst(x) = .Tag & "|" & .Value & "|" & .Name
                        End If
                    End If
                Case acListBox
                    '-------------------------------------------------------------------------------------------
                    'Een listbox kan meerdere items bevatten die geselecteerd worden.
                    'Die moeten allemaal apart worden uitgelezen.
                    '-------------------------------------------------------------------------------------------
                    If LCase(Left(.Name, 7)) = "listbox" Then
                    ''Set lst = frm(.Name).ListBox
                    tmp = .Name
                    Set lst = frm(tmp)
                        sKeuze = ""
                        iFltr = iFltr + 1
                        iLst = iLst + 1
                        If lst.ItemsSelected.Count >= 1 Then
                            x = x + 1
                            If x = 1 Then
                                ReDim sTekst(x)
                            Else
                                ReDim Preserve sTekst(x)
                            End If
                            For Each itm In lst.ItemsSelected
                                If sKeuze & "" <> "" Then sKeuze = sKeuze & "\"
                                sKeuze = sKeuze & lst.ItemData(itm)
                            Next itm
                            '-----------------------------------------------------------------------------------
                            'Ook hier wordt een samengestelde string gemaakt van de filterwaarden.
                            '-----------------------------------------------------------------------------------
                            sTekst(x) = .Tag & "|" & sKeuze & "|" & .Name
                        End If
                    End If
                Case acComboBox
                    If LCase(Left(.Name, 10)) = "Keuzelijst" Then
                        iFltr = iFltr + 1
                        If Not .Value = "" Then
                            x = x + 1
                            If x = 1 Then
                                ReDim sTekst(x)
                            Else
                                ReDim Preserve sTekst(x)
                            End If
                            If Right(.Name, 2) = "mv" Then
                                sTekst(x) = .Tag & ".Value|" & .Value & "|" & .Name
                            Else
                                sTekst(x) = .Tag & "|" & .Value & "|" & .Name
                            End If
                        End If
                    End If
                Case acCheckBox
                    If Left(ctl.Name, 13) = "Selectievakje" Then
                        iFltr = iFltr + 1
                        If Not .Value = "" Then
                            x = x + 1
                            If x = 1 Then
                                ReDim sTekst(x)
                            Else
                                ReDim Preserve sTekst(x)
                            End If
                            sTekst(x) = .Tag & "|" & .Value & "|" & .Name
                        End If
                    End If
                Case acOptionGroup
                    If LCase(.Name) = "fraUitkering" Then
                        If .Value > 0 Then
                            tmp = Split(frm("uitOpt" & .Value).Tag, "|")
                            iFltr = iFltr + 1
                            x = x + 1
                            If x = 1 Then
                                ReDim sTekst(x)
                            Else
                                ReDim Preserve sTekst(x)
                            End If
                            sTekst(x) = .Tag & "|" & tmp(UBound(tmp)) & "|" & .Name
                            iFltr = iFltr + 1
                            x = x + 1
                            ReDim Preserve sTekst(x)
                            sTekst(x) = tmp(LBound(tmp)) & "|" & "-1" & "|" & .Name
                        End If
                    End If
            End Select
        End With
    Next ctl
    
    '-----------------------------------------------------------------------------------------------------------
    'Als de tekstfilters leeg zijn, dan filter leegmaken en stoppen....
    '-----------------------------------------------------------------------------------------------------------
    If x = 0 Then GoTo LeegFilter
    '...... anders doorgaan, en matrix herdefiniëren.
    '===========================================================================================================
    
    '-----------------------------------------------------------------------------------------------------------
    'Dan de variabelen vullen met gegevens
    'We doen dat door een extra matrix te maken op basis van het filter
    '-----------------------------------------------------------------------------------------------------------
    ReDim sFilters(x, 3)
    For i = LBound(sFilters) To UBound(sFilters)
        tmpMatrix = Split(sTekst(i), "|")
        For x = LBound(tmpMatrix) To UBound(tmpMatrix)
            sFilters(i, x + 1) = tmpMatrix(x)
        Next x
    Next i
    i = 0
    x = 0
    '===========================================================================================================
    
    '-----------------------------------------------------------------------------------------------------------
    'Dan op basis van de variabelen het filter opbouwen
    '-----------------------------------------------------------------------------------------------------------
    Select Case frm.fraOptie.Value
        Case 1
            sAndOr = " AND "
        Case 2
            sAndOr = " OR "
    End Select
    If sAndOr = "" Then sAndOr = " AND "
    
        sFilter = ""
        For i = LBound(sFilters) To UBound(sFilters)
            If LBound(sFilters) = UBound(sFilters) Then
                '---------------------------------------------------------------------------------------------------
                'Het filter bestaat uit één element; dan hoeft er niks te worden samengesteld
                '---------------------------------------------------------------------------------------------------
                If InStr(sFilters(i, 2), "\") > 0 Then
                    '---------------------------------------------------------------------------------------------------
                    'Vervolgens controleren of de listbox meerdere items bevat, die gesplitst moeten worden.
                    'Die worden dan allemaal apart uitgelezen en in het filter gezet.
                    '---------------------------------------------------------------------------------------------------
                    tmpMatrix = Split(sFilters(i, 2), "\")
                    For x = LBound(tmpMatrix) To UBound(tmpMatrix)
                        '-------------------------------------------------------------------------------------------
                        'Eerst controleren of er getallen in het spel zijn, of tekst.
                        '-------------------------------------------------------------------------------------------
                        If IsNumeric(tmpMatrix(x)) Then
                            sFilter = sFilter & sFilters(i, 1) & " = " & tmpMatrix(x)
                        ElseIf IsDate(tmpMatrix(x)) Then
                            sFilter = sFilter & "CDate(" & sFilters(i, 1) & ") = " & CDbl(tmpMatrix(x))
                        Else
                            If LCase(Left(sFilters(i, 3), 10)) = "keuzelijst" Or LCase(Left(sFilters(i, 3), 3)) = "fra" Then
                                sFilter = sFilter & sFilters(i, 1) & " = """ & sFilters(i, 2) & """"
                            Else
                                sFilter = sFilter & sFilters(i, 1) & " Like ""*" & sFilters(i, 2) & "*"""
                            End If
                        End If
                        If x < UBound(tmpMatrix) Then sFilter = sFilter & " OR "
                    Next x
                Else
                    If IsNumeric(sFilters(i, 2)) Then
                        sFilter = sFilter & sFilters(i, 1) & " = " & sFilters(i, 2)
                    ElseIf IsDate(sFilters(i, 2)) Then
                        sFilter = sFilter & "CDate(" & sFilters(i, 1) & ") = " & CDbl(sFilters(i, 2))
                    Else
                        If LCase(Left(sFilters(i, 3), 10)) = "keuzelijst" Or LCase(Left(sFilters(i, 3), 3)) = "fra" Then
                            sFilter = sFilter & sFilters(i, 1) & " = """ & sFilters(i, 2) & """"
                        Else
                            sFilter = sFilter & sFilters(i, 1) & " Like ""*" & sFilters(i, 2) & "*"""
                        End If
                    End If
                 End If
            Else
                '---------------------------------------------------------------------------------------------------
                'Het filter bestaat uit meerdere elementen; het filter wordt samengesteld.
                '---------------------------------------------------------------------------------------------------
                If InStr(sFilters(i, 2), "\") > 0 Then
                    sFilter = sFilter & "("
                    tmpMatrix = Split(sFilters(i, 2), "\")
                    For x = LBound(tmpMatrix) To UBound(tmpMatrix)
                        '-------------------------------------------------------------------------------------------
                        'Uiteraard ook hier weer controleren of er getallen in het spel zijn, of tekst.
                        '-------------------------------------------------------------------------------------------
                        If IsNumeric(tmpMatrix(x)) Then
                            sFilter = sFilter & sFilters(i, 1) & " = " & tmpMatrix(x)
                        ElseIf IsDate(tmpMatrix(x)) Then
                            sFilter = sFilter & "CDate(" & sFilters(i, 1) & ") = " & CDbl(tmpMatrix(x))
                        Else
                            If LCase(Left(sFilters(i, 3), 10)) = "keuzelijst" Or LCase(Left(sFilters(i, 3), 3)) = "fra" Then
                                sFilter = sFilter & sFilters(i, 1) & " = """ & tmpMatrix(x) & """"
                            Else
                                sFilter = sFilter & sFilters(i, 1) & " Like ""*" & tmpMatrix(x) & "*"""
                            End If
                        End If
                        If x < UBound(tmpMatrix) Then sFilter = sFilter & " OR "
                    Next x
                    sFilter = sFilter & ")"
                Else
                    If IsNumeric(sFilters(i, 2)) Then
                        sFilter = sFilter & sFilters(i, 1) & " = " & sFilters(i, 2)
                    ElseIf IsDate(sFilters(i, 2)) Then
                        sFilter = sFilter & "CDate(" & sFilters(i, 1) & ") = " & CDbl(sFilters(i, 2))
                    ElseIf InStr(sFilters(i, 1), "#") > 0 And InStr(sFilters(i, 1), "/") > 0 Then
                        sFilter = sFilter & sFilters(i, 1)
                    Else
                        If LCase(Left(sFilters(i, 3), 10)) = "keuzelijst" Or LCase(Left(sFilters(i, 3), 3)) = "fra" Then
                            sFilter = sFilter & sFilters(i, 1) & " = """ & sFilters(i, 2) & """"
                        Else
                            sFilter = sFilter & sFilters(i, 1) & " Like ""*" & sFilters(i, 2) & "*"""
                        End If
                    End If
                End If
                If i < UBound(sFilters) Then
                    sFilter = sFilter & sAndOr
                End If
            End If
        Next i
        '===========================================================================================================
        
    '-----------------------------------------------------------------------------------------------------------
    'Filter vervolgens op aan functie toekennen.
    '-----------------------------------------------------------------------------------------------------------
    CheckFilter = sFilter
    Exit Function
    
    '-----------------------------------------------------------------------------------------------------------
    'Filter vervolgens op formulier toepassen.
    '-----------------------------------------------------------------------------------------------------------
    frm.Filter = sFilter
    frm.FilterOn = True
    '===========================================================================================================
    
    Exit Function
    
LeegFilter:
    frm.Filter = ""
    frm.FilterOn = False
    On Error Resume Next
    frm(Zoekveld).SetFocus

End Function
 
Goedenavond Michel,


Bedankt voor de reactie.
Dat de code veel te ingewikkeld is en niet te onderhouden is, was mij ook al duidelijk geworden.
Ik heb nu de keuzelijst namen aangepast en de functie in mijn test dB geplakt. Je voelt het waarschijnlijk al aankomen: hoe nu verder.
Dan gaat het om minimaal 2 dingen.
Welke code moet ik nu bij de keuzelijsten met invoervakken zetten en welke code onder de knop Excel zodat van de gemaakte keuze een Excel bestand kan maken.
In de bijlage een uitgeklede versie van de dB
Ik heb eerst de dB gezipt met winrar en toen de zip extensie veranderd in xlsb. Hopelijk kun je hem dan binnenhalen.

Alvast bedankt voor de hulp.

Gr. Jan

Bekijk bijlage Helpmij.xlsb
 
Ik heb mijn functie toegepast in jouw db; was niet zo moeilijk eigenlijk want je had het voorbereidende werk redelijk gedaan :) Enige opmerking op je formulier: selectievakjes staan voor elke gebruiker voor het kunnen kiezen van meerdere opties. Wil je een gebruiker één optie laten kiezen, dan verwacht die gebruiker dus optierondjes. Dat geldt voor jou vast ook :). Gebruik dus geen selectievakjes voor de keuze bij de merken maar rondjes.
 

Bijlagen

  • Helpmij.part01.rar
    100 KB · Weergaven: 35
  • Helpmij.part02.rar
    13,8 KB · Weergaven: 38
Hallo Michel,

Bedankt voor de code en de uitleg:thumb:.
Wat voor jou niet zo moeilijk is voor een amateurtje soms een hels karwei:D
Met jouw code werkt het veel beter en het belangrijkste is dat het veel beter te onderhouden is. Ik heb de selectievakjes veranderd in keuzerondjes en 3 keuzelijsten met invoervak veranderd in keuzelijsten (dat filteren gaat nu goed, ook als je bijv. meerdere merken kiest).
Ik heb nog een vraagje m.b.t. het excel bestand wat ik van de selectie wil kunnen maken. Onder de knop Excel wordt nu een query geopend en ik heb geen idee hoe ik de selectie in deze query moet opnemen.
Alle hulp is welkom.

Gr. Jan

Bekijk bijlage Helpmij1.part01.rarBekijk bijlage Helpmij1.part02.rar
 
Goedemorgen,

Ik ben nog wat verder gekomen met het zoeken naar de oplossing.
Helaas heb ik het nog niet goed werkend.
De listbox merken worden gevuld nadat je of een manager hebt gekozen of een groep merken hebt geselecteerd.
1. Als ik het filter formulier open dan krijg ik de melding dat de expressie niet juist is. Na comprimeren en herstellen krijg ik die melding niet,
2. Wat ik ook graag zou willen dat ik een Excel bestand kan maken van de gekozen velden. Het werkt wel als ik op de brede knop "Toon selectie" klik - dankzij de functie van Octafish. Het is mijn bedoeling dat die getoonde gegevens ook in een Excel bestand gezet kunnen worden. Ik ben al wel bezig geweest om een code te maken maar dat werkt niet goed. Het werkt niet op alle keuzelijsten en listboxes en het werkt helaas maar één keer (wel weer na comprimeren en herstellen van de dB. Als ik gegevens in de drie listboxes selecteer en ik klik op de Excel knop klik, dan wordt er een Excel bestand aangemaakt, Maak ik echter een nieuwe selectie dan krijg ik een foutmelding.

Bekijk bijlage Helpmij1.part01.rarBekijk bijlage Helpmij1.part02.rar

Wie kan mij verder helpen?

Gr. Jan
 
Ik kan daar vanavond/morgen naar kijken, want ik kan op het werk geen rar bestanden openen. Als je tijd hebt om de db op een fileshare te zetten (wikisend.com bijvoorbeeld) dan kan ik er vandaag nog wel even naar kijken.
 
Ik kan jouw hele export terugbrengen tot een paar regeltjes:
Code: 
Private Sub cmd_excel_Click()
Dim strSQL As String
    
    strSQL = "SELECT ID_afdeling_functie, Dealer_ID, Bedrijf, Adres, Postcode, Plaats, Afdeling, Merk_manager_ID, Afdeling_ID, Functie_ID, Medewerker_ID, " _
        & "Vr_medewerker, Am_medewerker, Merk_ID, Merk, Manager_ID, Soort_ID, AGCO " _
        & "FROM tbl_medewerkers INNER JOIN (tbl_afdelingen INNER JOIN (tbl_merken INNER JOIN (tbl_dealer INNER JOIN tbl_afdeling_functie " _
        & "ON tbl_dealer.ID_dealer = tbl_afdeling_functie.Dealer_ID) ON tbl_merken.ID_merk = tbl_afdeling_functie.Merk_ID) " _
        & "ON tbl_afdelingen.ID_afdeling = tbl_afdeling_functie.Afdeling_ID) ON tbl_medewerkers.ID_medewerker_dealer = tbl_afdeling_functie.Medewerker_ID " _
        & "WHERE " & Me.Filter & " " _
        & "ORDER BY Zoeknaam;"
    Set qdf = CurrentDb.QueryDefs("qExportExcel")
    qdf.SQL = strSQL
    DoCmd.OutputTo acOutputQuery, "qExportExcel", "ExcelWorkbook(*.xlsx)", "Selectie.xlsx", True
   Exit Sub

cmd_excel_Click_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmd_excel_Click of VBA Document Form_frm_filter_gegevens"
End Sub
Daarbij heb ik zelfs je exportfile nog uitgebreid met een paar velden, want je query en formulier laten wel de juiste gegevens zien, maar die zitten niet in de export; daar zie je namelijk alleen de feitenlijke waarden uit de tabel terug en dat zijn dus de sleutelvelden. Om de tekstvelden te zien, moet je die dus toevoegen aan de query.
De foutmelding waar je het over had kan ik niet reproduceren; de db deed het gelijk al goed. Je andere probleem heb ik niet eens geprobeerd te testen, want ik werd veuls te moe van het lezen van de code :).
 
Hallo Michel,

Bedankt voor de snelle reactie, het is inderdaad een stuk simpeler op deze manier.
Al die code is eigenlijk ontstaan doordat ik niet wist wat ik bij WHERE moest ingeven. Ja, en dan krijg je zoiets.
En dan zie ik nu bij jou wat het is: WHERE " & Me.Filter & ". Hoe eenvoudig kan het zijn.

De foutmelding kreeg ik alleen als ik vanuit de formulier ontwerp weergave terug ging naar de formulier weergave.
Het aanpassen van de query gaat me wel lukken.

Nog een klein vraagje over de qExportExcel die ini je code zit. Bij mij bestaat deze niet, ik heb deze nu handmatig toegevoegd maar er is vast een manier om deze automatisch toe te voegen als deze niet bestaat.

Alvast bedankt voor je reactie.

Gr. Jan
 
Dat kan inderdaad wel;
Code: 
Set qTemp = CurrentDb.CreateQueryDef("qExcelExport", strSQL)
Probleem is dan alleen dat je een foutmelding krijgt als hij al bestaat. Andersom krijg je dus een foutmelding als je hem met
Code: 
Set qTemp = CurrentDb.QueryDefs("qTempZoekresultaat")
probeert te vullen en hij bestaat niet. Je moet dus, of je links of rechtsom gaat, een foutafhandeling inbouwen met On Error Goto. In die foutafhandeling maak je de querydef als hij nog niet bestaat, of ga vul je de bestaande als hij wél bestaat. Maakt allemaal niet zoveel uit, want je krijgt de fout maar één keer als het goed is. Het leuke is: je kunt elke query gebruiken die je wilt, of maken zelfs. Als je
Code: 
Set qTemp = CurrentDb.CreateQueryDef("qExcelExport")
gebruikt, krijg je namelijk óók een query, alleen zit daar dan niks in. En dat maakt dus niet uit, want je vult hem toch steeds vanuit je VBA met wat anders. Ik gebruik vaak één tijdelijke query die steeds een andere SQL krijgt.
 
Hallo Michel,

Ik ben nog weer even aan het stoeien geweest met de code.
Het is deze code geworden en voor mij werkt het prima.:thumb:
Weer hartelijk bedankt voor het uitstekende advies. De CheckFilter functie werkt zeer goed en ik zie in andere databases die ik gemaakt heb ook wel verbeterpunten op dit onderdeel.

Code: 
         Set qTemp = CurrentDb.QueryDefs("qExportExcel")
        qTemp.SQL = strSQL
        DoCmd.OutputTo acOutputQuery, "qExportExcel", "ExcelWorkbook(*.xlsx)", "Selectie.xlsx", True
               
   On Error GoTo 0
   Exit Sub

cmd_excel_Click_Error:

    Select Case Err.Number
        Case 3145
            MsgBox "Je hebt nog geen keuze(s) gemaakt." & vbCrLf _
                & "" & vbCrLf _
                & "Eerst een keuze maken en dan opnieuw op de EXCEL knop klikken.", vbOKOnly Or vbInformation, Application.Name
                Exit Sub
        Case 2302
            MsgBox "Je hebt nog een Excel bestand open staan." & vbCrLf _
                & "" & vbCrLf _
                & "Deze eerst sluiten en dan opnieuw op de EXCEL knop klikken.", vbOKOnly Or vbInformation, Application.Name
        Case 3265
            Set qTemp = CurrentDb.CreateQueryDef("qExportExcel", strSQL)
    End Select

Ik sluit bij deze de vraag af.

Mvg
Jan
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan