Horizontaal filteren

[Kaalbartje]

Hoi,

Ik zou graag horizontaal willen filteren.
In het voorbeeldje zie je een aantal datums. In rij 1 twee datums. Filtering zou plaats moeten vinden aan de hand van deze datums.
Als wat gezocht maar nog niet de oplossing kunnen vinden. Ben bang dat het VBA zal moeten maar daar ben ik niet handig mee.
Ik had wel deze gevonden waarbij je in ieder geval naar de startdatum springt: https://www.helpmij.nl/forum/showthread.php/819553-Zoekfunctie-invoegen maar dat is niet helemaal wat ik zoek. Kan hem overigens ook niet aanpassen voor datums.

 

[emields]

geef eens een voorbeeldje van wat je zou willen bereiken

 

[Kaalbartje]

Hoi,

Er komen straks heel veel datums te staan. Ik zou dan alleen een x aantal datums willen tonen, het liefst met een van tot selectie.

Zo helderder?

 

[VenA]

Horizontaal filteren kan alleen met een macro. Dat geeft ook gelijk de slechte opzet van het bestand aan. In de kolomkoppen van een tabel kan je geen datums zetten, deze worden omgezet naar tekst.
Filteren is in basis niets anders dan verbergen of zichtbaar maken van bepaalde zaken.

Met een paar aanpasinningen in jouw bestand kan het op deze manier.

De code kan nog wel wat eenvoudiger maar zo is het nog een beetje te volgen.

 

[cow18]

kan vermoedelijk alleen via VBA.
Onderstaande macro is een toggle AAN-UIT, dus doet het gevraagde en in de volgende run worden weer alle kolommen getoond.

Sub Horizontaal()
   With Sheets("blad2")
      Set c = .UsedRange.Rows(2)                 'gebruikt bereik beperken tot rij 2
      On Error GoTo ToonAlles                    'loopt er iets fout in de volgende rij = alle kolommen tonen
      If c.SpecialCells(xlVisible).Count <> c.Cells.Count Then GoTo ToonAlles   'toggle-functie, vorige keer minstens 1 kolom verborgen = eerst alles terug tonen
      On Error GoTo 0                            'einde reageren op fout

      rij2 = Application.Transpose(Application.Transpose(c))   ' gegevens >> array
      kol1 = Application.Match(Format(.Range("b1").Value, "d-m-yyyy"), rij2, 0)   'positie datum "VAN"
      kol2 = Application.Match(Format(.Range("C1").Value, "d-m-yyyy"), rij2, 0)   'positie datum "TOT"

      If IsNumeric(kol1) And IsNumeric(kol2) Then   'beide datums gevonden
         If kol1 > kol2 Then GoTo ToonAlles      'VAN groter dan TOT = alles tonen
         c.EntireColumn.Hidden = True            'eerst c helemaal verbergen
         c.Cells(1).EntireColumn.Hidden = False  '1e kolom altijd tonen
         c.Offset(, kol1 - 1).Resize(, kol2 - kol1 + 1).EntireColumn.Hidden = False   'dit deel ook tonen
      Else
         GoTo ToonAlles                          'minstens 1 datum niet gevonden
      End If
   End With
   Application.Goto c, 0
   Exit Sub

ToonAlles:
   c.EntireColumn.Hidden = False
End Sub

oei, VenA was net een beetje sneller ...

 

[Kaalbartje]

Hoi VenA

Tnx, ik ben het geheel met je eens maar dit is een onderdeel van een groter geheel. Je hebt mij super geholpen.

 

[VenA]

Als het onderdeel is van een groter geheel dan moet je ook even de code van @cow18 bekijken. Hoewel het een compleet andere invalshoek is, zitten er wel een paar controles in die ik niet gebruikt heb.

Bij geen begindatum of geen einddatum of een einddatum die kleiner is dan de begindatum ga je in mijn code een foutmelding krijgen. Geen verstand van of weinig ervaring met VBA is geen excuus om niet zelf fouten te proberen genereren en er een oplossing voor te verzinnen.

 

[Kaalbartje]

Hahaha, nou geloof me die fouten ga ik zeker wel creëren, bewust dan wel niet onbewust.
Ik zal zeker de code van cow18 ook gebruiken en testen.

Beide tnx

 

[Kaalbartje]

Ben echt waardeloos met VBA.
Ik heb het script toegepast van VenA. Maar geeft aan subscript valt buiten bereik. Zie bijlage. Komt het misschien door de samengestelde cellen?
Van Cow18 weet ik even niet hoe ik die moet activeren en deactiveren.

 

[cow18]

het is natuurlijk grappig als het definitief bestand er toch een klein beetje anders uitziet dan het voorbeeldbestand.
Vooral samengestelde cellen zijn een gruwel.

En natuurlijk sta ik ook soms voor een raadsel.
In je voorbeeldbestand stonden je datums in een "d-m-jjjj"-opmaak, hier in een "ddd d/m/jjjj"-opmaak.
Normaal moest ik dan 1 en ander binnen VBA aanpassen, zodat er netjes gezocht kan worden in de te doorzoeken array.
In vorige versie moest ik dus de opmaak van de zoekwaarden "Van" en "Tot" binnen VBA aanpassen naar die heersende "d-m-jjjj"-opmaak maar hier naar Long !???!
Soms begrijp ik, nochtans als gevorderde, ook niet de logica hierachter ... .
Het is gewoon vaststellen, dat het niet werkt op de manier dat je in gedachten had en dan aanpassen.
Komt het door die samengestelde cellen of door iets anders, ik heb het niet uitgezocht.

Bon, mijn macro staat in module 1 en ik heb nu die groene knop voorzien, waarachter die macro zit.
Daarnaast is er ook een macro die reageert op een verandering in je tabblad, die change-macro in de module van "Personeel".
Verder zijn er 3 gedefinieerde bereiken, die met je datums "Van" en "Tot" en dan al die datums in je samengestelde cellen.

De groene knop en dus de macro "horizontaal" zal in toggle-mode, dus om-en-om, alle kolommen tonen of zich beperken tot de gewenste kolommen.
Daarnaast, als je 1 van de datums "Van" of "Tot" verandert, dan zouden de kolommen zich ook direkt vanzelf moeten aanpassen. (door die Change-event)

 

[Kaalbartje]

Hoi Cow18,

Je hebt uiteraard volledig gelijk. Ik was alweer verder gegaan en probeerde de situatie toe te passen op de nieuwe versie. Komt door geen verstand van VBA dat ik niet weet wat de impact is.
Maar je hebt het geweldig opgelost. Sorry voor het extra werk.......

Super dank voor je werk!
:thumb:

 

[gerArt]

Een kleine wellicht leuke aanvulling op de toggle-mode. Heb ooit een stukje code gevonden waarbij de tekst, die je aan kan passen, in de knop wijzigt van tekst en kleur bij het gebruik er van.

 

[cow18]

@gerArt, dat is inderdaad een leuke aanvulling !:thumb:

Alleen zou ik in het stuk waar je opnieuw alle kolommen wilt tonen, de macro "uit" van VenA aanroepen.
Je riskeert anders dat de tekst op de knop en de uitvoering van de macro uit de pas met elkaar lopen.
Maak anders eens dat alle kolommen zichtbaar zijn en verberg daarna 1 kolom handmatig buiten de macro om.
Druk nu een paar keer op de knop en je zal vaststellen dat wat er op de knop staat en de uitvoering van de macro niet overeenstemmen.
Dat zou ook maximaal 1 keer kunnen gebeuren met die voorgestelde aanpassing, daarna zijn beiden terug synchroon.

 

[gerArt]

Helemaal gelijk. Kleine aanpassing groot gemak

 

[Kaalbartje]

Tnx voor de leuke toevoeging. Volgens mij heb je die verbetering in je bestand al aangepast of niet? Ik krijg in ieder geval geen gekke filtering zoals Cow18 beschrijft.
:thumb:

 

[gerArt]

Nee in het bestand is dat nog niet aangepast. Wat je moet doen is;

Sub Uit()
   Sheets("Personeel").Columns.Hidden = False
End Sub

dit in het blad Personeel staat te knippen en plakken in een aparte module. Daarna onderstaande tekst in het rood

Sub AanUit_Kolommen()
    With ActiveSheet.Shapes("Filter").TextFrame.Characters
        If .Text = "Filter Uit" Then
            .Text = "Filter Aan" & vbCrLf & Range("B1") & "   " & vbCrLf & Range("B2")
            .Font.ColorIndex = 3
      Call Horizontaal
        
        Else
            .Text = "Filter Uit"
            .Font.ColorIndex = 1
     
     [COLOR="#FF0000"]Call Horizontaal[/COLOR]
     End If
    End With
End Sub

wijzgen in;

Call uit

 

[Kaalbartje]

Geeft een foutmelding.
Ik zal de codes hieronder tonen

Module1

Sub Horizontaal()
   With Sheets("personeel")
      Set c = Range("MijnDatums")                'bereik wordt bepaald door een gedefinieerde naam
      On Error GoTo ToonAlles                    'loopt er iets fout in de volgende rij = alle kolommen tonen
      If c.SpecialCells(xlVisible).Count <> c.Cells.Count Then GoTo ToonAlles   'toggle-functie, vorige keer minstens 1 kolom verborgen = eerst alles terug tonen
      On Error GoTo 0                            'einde reageren op fout

      rij2 = Application.Transpose(Application.Transpose(c))   ' gegevens >> array
      kol1 = Application.Match(CLng(Range("Van").Value), rij2, 0)   'positie datum "VAN" (omzetten naar Long)
      kol2 = Application.Match(CLng(Range("Tot").Value), rij2, 0)   'positie datum "TOT" (omzetten naar Long)

      If IsNumeric(kol1) And IsNumeric(kol2) Then   'beide datums gevonden
         If kol1 > kol2 Then GoTo ToonAlles      'VAN groter dan TOT = alles tonen
         c.EntireColumn.Hidden = True            'eerst c helemaal verbergen
         c.Offset(, kol1 - 1).Resize(, kol2 - kol1 + 3).EntireColumn.Hidden = False   'dit deel ook tonen, hou rekening met samengesteld karakter !!!
      Else
         GoTo ToonAlles                          'minstens 1 datum niet gevonden
      End If
   End With
   'Application.Goto c, 0
   Exit Sub

ToonAlles:
   c.EntireColumn.Hidden = False
End Sub
Sub AanUit_Kolommen()
    With ActiveSheet.Shapes("Filter").TextFrame.Characters
        If .Text = "Klik om de filter aan te zetten" Then
            .Text = "Filter aan" & vbCrLf & Range("B1") & "   " & vbCrLf & Range("B2")
            .Font.ColorIndex = 2
      Call Horizontaal
        
        Else
            .Text = "Klik om de filter aan te zetten"
            .Font.ColorIndex = 1
     
     Call Uit
     End If
    End With
End Sub

Module2

Sub Uit()
   Sheets("Personeel").Columns.Hidden = False
End Sub

Blad1(personeel):

Sub Aan()
   With Sheets("Personeel").ListObjects(1)
      x = .Range.Cells(1).Column
      .Parent.Columns(x + 1).Resize(, .Range.Columns.Count).Hidden = True
      y = Application.Match(Format(.Parent.Cells(1, 2), "dd-m-yyyy"), .HeaderRowRange, 0)
      Z = .Parent.Cells(2, 2) - .Parent.Cells(1, 2) + 1
      .Parent.Columns(y - 1 + x).Resize(, Z).Hidden = False
   End With
End Sub

Private Sub CommandButton1_Click()
   Horizontaal
End Sub

Private Sub DTPicker1_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   If Intersect(Target, Range("B1:B2")) Is Nothing Then Exit Sub 'verander je iets anders dan 1 van beide datums = stoppen, anders ...
   Uit                                           'VenA's macro alle kolommen tonen
   Horizontaal                                   'Cow's macro tonen bepaalde kolommen
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Geeft een foutmelding op: .Text = "Filter aan" & vbCrLf & Range("B1") & " " & vbCrLf & Range("B2") uit Module1

 

[gerArt]

Hierbij het bestand zoals ik het nu heb.

 

[snb]

een vereenvoudigde versie:

en ook de formule vereenvoudigd

 

[Kaalbartje]

lekker bezig snb.
Dank voor beide.