Lijst met tabbladen aanmaken a.d.h.v. een datum

[Basbrommer]

Hallo,

Ik wil graag een lijst aanmaken van tabbladen die eerst wordt gecontroleerd op een datum. In elk tabblad staat in cel BA1 een datum, als deze datum langer 31 dagen geleden is wil ik hem niet in de lijst hebben. Daarnaast wil ik als hij wel wordt geplaatst dat er direct een link aan verbonden is zodat mensen er direct op kunnen klikken om naar dat bewuste tabblad te gaan. De tabbladen hebben namen van activiteiten die gedaan zijn of nog gedaan moeten worden. Op het eerste tabblad (Start) wil ik deze lijst hebben.

Kan iemand mij helpen om hiervoor een macro te maken?

Met vriendelijk groeten Bas Immerzeel

 

[Warme bakkertje]

Hier kan je al mee starten

Sub tst()
For Each sh In Sheets
    If sh.Name <> "Start" Then
        If sh.Range("BA1") <> "" Then
            If DateValue(sh.Range("BA1")) > DateValue(Date - 31) Then
                With Sheets("Start")
                    .Hyperlinks.Add .Cells(Rows.Count, 1).End(xlUp).Offset(1), "#" & sh.Name & "!$A$1", , , sh.Name
                End With
            End If
        End If
    End If
Next
End Sub

 

[Basbrommer]

Dank je wel Warme bakkertje,

Het werkt! Je hebt ons daar echt mee geholpen.
Ik zie dat de lijst keurig begint op cel A1, maar ik zou graag wil dat begint op K10. Wat moet ik veranderen zodat hij op die cel start?

Groet Bas

 

[zapatr]

Ik zie dat de lijst keurig begint op cel A1, maar ik zou graag wil dat begint op K10. Wat moet ik veranderen zodat hij op die cel start?

Probeer nou zelf ook eens iets.
Dit is echt niet zo moeilijk.

 

[Warme bakkertje]

Sub tst()
LRow = 10
For Each sh In Sheets
    If sh.Name <> "Start" Then
        If sh.Range("BA1") <> "" Then
            If DateValue(sh.Range("BA1")) > DateValue(Date - 31) Then
                With Sheets("Start")
                    .Hyperlinks.Add .Cells(LRow, 11), "#" & sh.Name & "!$A$1", , , sh.Name
                    LRow = LRow + 1
                End With
            End If
        End If
    End If
Next
End Sub

 

[Basbrommer]

Hoi Zapatr

Ik voel me heel dom, maar ik weet het echt niet. Ik heb van alles geprobeerd en het lukt me niet. Krijg iedere keer een foutmelding of doet niet wat ik wil.
De macro's in excel maak ik meestal door de macro op te nemen en dan een klein beetje aanpassen met mijn eigen kennis. Maar dit soort formules kan ik niet maken en ben ik daar een leek in.
Dus vraag ik nogmaals of iemand mij hierbij kan helpen.

Groet Bas

 

[zapatr]

Dus vraag ik nogmaals of iemand mij hierbij kan helpen

Voldoet de code in het tweede antwoord van Bakkertje niet ?

 

[Basbrommer]

Hoi Zapatr,

Ik had de vorige reactie nog niet gelezen maar had wel al die tijd het forum oprn staan vandaar. Dat ga ik nu uitproberen en al vast bedankt voor de reactie.

Groet Bas

 

[Basbrommer]

Het werkt!

Hartelijk dank Rudi!

Groet Bas

 

[Basbrommer]

Hallo Rudi en Zapatr,

Ik ben verder gegaan met mijn bestand maar nu krijg ik een foutmelding;
"Fout 13 tijdens uitvoering:"
"Typen komen niet met elkaar overeen"

Sub OverzichtProjecten()
Dim Aantal As Integer
Aantal = 0
LRow = 12
Dim DatumOpen As Date

For Each Sh In Sheets
    If Sh.Name <> "Start" Then
        If Sh.Range("BA1") <> "" Then
            If DateValue(Sh.Range("BA1")) > DateValue(Date - 31) Then
                Aantal = Aantal + 1
            End If
        End If
    End If
Next
If Aantal > 0 Then
Range("K10") = "De volgende projecten staan nog open:"
    For Each Sh In Sheets
        If Sh.Name <> "Start" Then
            If Sh.Range("BA1") <> "" Then
                If DateValue(Sh.Range("BA1")) > DateValue(Date - 31) Then
                    With Sheets("Start")
                        .Hyperlinks.Add .Cells(LRow, 11), "#" & Sh.Name & "!$A$1", , , Sh.Name
                        Sh.Range("BA1") = DatumOpen
                        DatumOpen = DatumOpen + 31
                        Sluiting = DatumOpen - Date
                        Cells(LRow, 17) = Sluiting
                        LRow = LRow + 1
                    End With
                End If
            End If
        End If
    Next
End If
Range("K10:Q23").Select
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Vet"
        .Size = 16
        .ColorIndex = 2
    End With
    With Selection.Interior
        .ColorIndex = 11
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    Range("B4").Select
    
End Sub

Wat is er fout gegaan want eerst werkte het wel en nu niet meer. Heb zelf nog geprobeerd om te kijken wat er veranderd is maar daar kom ik niet achter.
Kan iemand mij hierbij helpen?

Groet Bas

 

[Warme bakkertje]

Sh.Range("BA1") = DatumOpen
DatumOpen = DatumOpen + 31
Sluiting = DatumOpen - Date
Cells(LRow, 17) = Sluiting

Hier ga je de fout in. Je geeft BA1 de waarde van DatumOpen, maar je moet wel eerst een waarde toekennen aan DatumOpen alvorens je deze wegschrijft. Je krijgt maw een lege cel waarmee je verder wil rekenen.
Maar mi probeer je de waarde van BA1 toe te kennen aan DatumOpen dus wordt het

DatumOpen = sh.Range("BA1")

 

[Basbrommer]

Hoi Rudi,

Bedankt voor je hulp en ik heb het meteen aangepast, maar de fout begint al eerder. In de eerste deel zit de regel;

If DateValue(Sh.Range("BA1")) > DateValue(Date - 31) Then

en daarop krijg ik de foutmelding.

Groet Bas

 

[Warme bakkertje]

Dan moet je toch iets gewijzigd hebben in je bestand, want eerst wel en nu ineens zonder iets te wijzigen niet meer, lijkt mij toch sterk.

 

[Basbrommer]

Ja dat klopt.Ik maak iedere keer een copie dus kan ik dingen terug halen. Nu heb ik de formule die ik van jou heb gekregen (zonder er iets aan te veranderen) opnieuw gebruikt in het laatste bestand en dan werkt hij voor 1 keer. Daarna krijg ik de fout melding als ik het wil herhalen. Ik vind dat vreemd en weet niet wat ik verkeerd doe. Voorheen kwam die foutmelding niet.