Jaar berekenen

[Neuz]

Hey allemaal,

Ik ben op zoek naar een vba script welke voor mij makkelijk een heel jaar op een werkblad
kan zetten.

Wat ik precies wil is dat de gebruiker een jaartal invult in een userform en dat de macro
vervolgens kijkt of het een schrikkeljaar is of niet en daarna alle data op het werkblad gaat
wegschrijven in het formaat d-m-yyyy (yyyy moet dan wel het jaar zijn welke door de
gebruiker is ingevoerd)

Op dit moment gebruik ik het volgende script wat ik op internet heb gevonden.

Private Sub CommandButton1_Click()
    If Not IsNumeric(Me.TxtJaartal.Value) Then
        MsgBox "U dient een geldig jaartal in te voeren", vbInformation, "Jaar berekenen"
        Me.TxtJaartal.SetFocus
        Exit Sub
    End If
    
    With Worksheets("Blad3")
        .Range("A:A") = ""
        .Range("A1") = Me.TxtJaartal
        
        If .Range("B1") = "Normaal jaar" Then
            .Range("A3") = "=DATE(Blad3!A1,1,1)"
            .Cells(3, 1) = DateValue("1-1")
            .Cells(3, 1).AutoFill .Cells(3, 1).Resize(365)
        ElseIf .Range("B1") = "Schrikkel jaar" Then
            .Range("A3") = "=DATE(Blad3!A1,1,1)"
            .Cells(3, 1) = DateValue("1-1" & Me.TxtJaartal.Value)
            .Cells(3, 1).AutoFill .Cells(3, 1).Resize(366)
        End If
    End With
    Unload Me
End Sub

In de cel B1 staat de volgende formule

=ALS(A1<>"";ALS(OF(REST(A1;400)=0;EN(REST(A1;4)=0;REST(A1;100) <> 0));"Schrikkel jaar";"Normaal jaar");"")

Deze geeft aan of het schirkkeljaar of een normaal jaar is.

Zouden jullie me kunnen helpen dit probleem op te lossen?

Alvast bedankt voor de moeite.

Groet Neuz

 

[pasan]

1. als bovenstaande code en formule doet wat jij wil wat is dan het probleem?
2. je zegt "wegschrijven"....... waar naar toe?

Kun je een voorbeeld bestand plaatsen met userform? en hoe wil je deze form geopend hebben? door een knop of dubbel klikken op een cel? of bij openen bestand ????

Met een voorbeeld bestand krijg je vast jou beoogde hulp, helaas ben ik de komende dagen op vakantie

 

[edmoor]

Kijk voor een leuk voorbeeld document eens naar #6 in dit draadje:
http://www.helpmij.nl/forum/showthread.php/822399-Urenlijst-maken-in-Access?highlight=tabblad+maand

 

[Neuz]

Beste pasan,

De bovenstaande code doet niet precies wat ik wil.
De code neemt namelijk het jaartal wat er wordt ingevuld niet over, deze komt standaard op 2014 te staan.
Ik wil alle data wegschrijven in de cellen A3 t/m A... (ligt eraan of het een schrikkeljaar is of niet).

Het bovenstaande script heb ik als oefening gebruikt uiteindelijk wil ik met selection change alles automatisch
laten vullen. Dit lukte me niet dus dacht dat het zo makkelijker zou gaan.

Hierbij een voorbeeld document waarin beide mogelijkheden staan.
Bekijk bijlage Schrikkeljaar berekening.xlsm

Hopelijk kun je me op weg helpen, fijne vakantie in ieder geval.

Groet Neuz

 

[Neuz]

Hey Edmoor,

Ja zo iets bedoel ik maar dan wil de ik data onderelkaar hebben op hetzelfde werkblad
in de range A3 t/m A... (ligt aan schrikkeljaar of niet). En dan in het formaat dd-mm-jjjj.

Alvast bedankt.

Groet Neuz

 

[edmoor]

Ik liet die zien als voorbeeld. Die kun je eenvoudig naar eigen smaak aanpassen.

 

[Neuz]

Beste Edmoor,

Ik heb naar je script gekeken maar snap er echt helemaal niets van.
Heb je misschien ook een document waar opmerkingen in staan zodat
ik zelf kan gaan proberen en er ook nog iets van leer?

Hoor het graag van je.

Groet Neuz

 

[pasan]

Een mogelijkheid (nu ben ik toch echt vertrokken):d

Private Sub CommandButton1_Click()

    If Not IsNumeric(Me.TxtJaartal.Value) Then
        MsgBox "U dient een geldig jaartal in te voeren", vbInformation, "Jaar berekenen"
        Me.TxtJaartal.SetFocus
        Exit Sub
    End If
    
    aantaldagen = DateSerial(TxtJaartal, 12, 31) - DateSerial(TxtJaartal - 1, 12, 31)
    eerstedag = DateSerial(TxtJaartal, 1, 1)
    laatstedag = DateSerial(TxtJaartal, 12, 31)
    Worksheets("Blad3").Range("A:A") = ""
    
    For i = eerstedag To laatstedag
      j = j + 1
    With Worksheets("Blad3")
        
        .Range("A1") = Me.TxtJaartal
        .Cells(1 + j, 1) = i
    End With
        Next

     Worksheets("Blad3").Range("B1") = IIf(aantaldagen > 365, "Schrikkel jaar", "Normaal jaar")

    Unload Me
End Sub

 

[edmoor]

Dat ziet er qua code goed uit Pasan. Maar qua leesbaarheid zou ik de For loop toch zo doen:

For i = eerstedag To laatstedag
    j = j + 1
    With Worksheets("Blad3")
        .Range("A1") = Me.TxtJaartal
        .Cells(1 + j, 1) = i
    End With
Next

 

[pasan]

@edmoor vanuit zonovergoten camping ik zie geen verschil in de code

 

[edmoor]

Klopt. Want die was al prima
Het ging me om de leesbaarheid, dus de inspringpunten aangepast.

Geniet lekker op de camping :thumb:

 

[Warme bakkertje]

Het enige dat nog voor verbetering vatbaar is , is het wegschrijven in 1 keer ipv cel per cel.

Private Sub CommandButton1_Click()
    Dim mydates() As Date
    If Not IsNumeric(Me.TxtJaartal.Value) Then MsgBox "U dient een geldig jaartal in te voeren", _
            vbInformation, "Jaar berekenen": TxtJaartal.SetFocus: Exit Sub
    j = 1
    aantaldagen = DateSerial(TxtJaartal, 12, 31) - DateSerial(TxtJaartal - 1, 12, 31)
    eerstedag = DateSerial(TxtJaartal, 1, 1): laatstedag = DateSerial(TxtJaartal, 12, 31)
    ReDim mydates(1 To aantaldagen, 1 To 1)
    For i = eerstedag To laatstedag
        mydates(j, 1) = i: j = j + 1
    Next
    With Sheets("Blad3")
        .Columns(1).ClearContents
        .Cells(1) = TxtJaartal.Text
        .Cells(2, 1).Resize(UBound(mydates)) = mydates
        .Cells(1, 2) = IIf(aantaldagen > 365, "Schrikkel jaar", "Normaal jaar")
    End With
    Unload Me
End Sub