Dynamische kalender obv input data

[vriestimeos]

Hallo,

Ik heb een VBA uitdaging waar ik niet uitkom. Ik heb al veel dingen geprobeerd maar het lukt me niet om mijn kalender dynamisch te krijgen.
Ik heb een voorbeeld toegevoegd. Dit betreft een rapportagekalender die ik op mijn werk wil uitrollen.
Ik heb 3 werkbladen: input, en de maanden januari en februari.

Nu wil ik in het tabblad Input werken om data te registreren (qua start werkzaamheden, afstemming, en indiening).
Data voor planning, herplanning en realisatie.

Nu wil ik door middel van VBA deze data (dus bv. start Rapportage A) laten plotten in de kalender in de betreffende maand. Mijn baas krijgt dus alleen de kalender (Januari, Februari) te zien.
Er kunnen dus meerdere rapportages (qua start, afstemming, indiening, maar ook herplanning etc.) op dezelfde dagen vallen.
De lay-out van de kalender (dus de blokken per dag) staan vast.

Dus als een datum in de input wijzigt, moet de data in de betreffende kalendermaand meewijzigen.

Is er een (simpele) oplossing hiervoor? Wie wil deze uitdaging aan?

 

[Elsendoorn2134]

Vriestimeos,

Kort gezegd, nee, een simpele oplossing is er niet, een ingewikkelde wel.
Eerst een voor de hand liggende vraag.

Mag sheet Input wijzigen, ik zou deze liever in een tabel met kolommen hebben als Maand, Rapport, Actie, Stadium, Datum
Dat zou de macro een stuk makkelijker maken. Nu weet ik niet hoeveel maanden ik af moet lopen.

Elsendoorn2134

 

[Elsendoorn2134]

Vriestimos,

Ik ben er even voor gaan zitten en op zich viel je programmaatje wel mee.
Ik heb een uitwerking gemaakt op basis van een verandering van de inputsheet waarbij ik de input in een tabel
heb opgenomen.

Ik begin mijn programma met het schonen van de maanden.

Daarna lees ik de tabel in een array waarna ik in de betreffende maanden naar de dag zoek.

Dan kijk ik wat het eerste vrije veld is onder de betreffende dag en plaats ik de rapportage, de actie en de status.
Afijn, hierbij de macro en het bestand:

Private Type Record
    sMaand As String
    sRapport As String
    sActie As String
    sStatus As String
    dDatum As Date
End Type

Public Sub PlotData()

Dim Database(1000) As Record
Dim nTeller As Integer
Dim nRegel As Integer
Dim wSheet As Worksheet
Dim rZoekRange As Range
Dim rDoelRange As Range

'Schonen van alle maanden.
For Each wSheet In ActiveWorkbook.Sheets
    If Left(wSheet.Name, 5) <> "Input" Then
        wSheet.Range("B5:H12").ClearContents
        wSheet.Range("B14:H21").ClearContents
        wSheet.Range("B23:H30").ClearContents
        wSheet.Range("B32:H39").ClearContents
        wSheet.Range("B41:H48").ClearContents
    End If
Next

'Lees tabel.
With Sheets("Input2").Range("A1")
    For nTeller = 1 To Range("E100000").End(xlUp).Row
        Database(nTeller).sMaand = IIf(.Offset(nTeller, 0) = "", Database(nTeller - 1).sMaand, .Offset(nTeller, 0))
        Database(nTeller).sRapport = IIf(.Offset(nTeller, 1) = "", Database(nTeller - 1).sRapport, .Offset(nTeller, 1))
        Database(nTeller).sActie = IIf(.Offset(nTeller, 2) = "", Database(nTeller - 1).sActie, .Offset(nTeller, 2))
        Database(nTeller).sStatus = IIf(.Offset(nTeller, 3) = "", Database(nTeller - 1).sStatus, .Offset(nTeller, 3))
        Database(nTeller).dDatum = .Offset(nTeller, 4)
    Next
End With

'Tabel ingelezen nu plotten in de maand.
nTeller = 1

'Doorlopen van de tabel.
Do While Database(nTeller).sMaand <> ""
    'Zoek de datum
    If Database(nTeller).dDatum <> 0 Then
        Set rZoekRange = Sheets(Database(nTeller).sMaand).Range("B4:H40").Find(Day(Database(nTeller).dDatum), _
            LookIn:=xlValues, Lookat:=xlWhole)
        If Not rZoekRange Is Nothing Then
            'Als gevonden de eerst volgende lege cel vinden onder de datum.
            nRegel = 1
            Do While Sheets(Database(nTeller).sMaand).Range(rZoekRange.Address).Offset(nRegel, 0) <> ""
                nRegel = nRegel + 1
            Loop
            Set rDoelRange = Sheets(Database(nTeller).sMaand).Range(rZoekRange.Address).Offset(nRegel, 0)
            'Invoeren van de gegevens in de betreffende cel.
            Sheets(Database(nTeller).sMaand).Range(rDoelRange.Address) = _
                Database(nTeller).sRapport & " " & _
                Database(nTeller).sActie & " " & _
                Database(nTeller).sStatus
        Else
            'Als niet gevonden fout melden en afbreken.
            MsgBox "Heb datum " & Database(nTeller).dDatum & " niet kunnen vinden" & vbCrLf & "op tabblad " & Database(nTeller).sMaand
            End Sub
        End If
    End If
    nTeller = nTeller + 1
Loop
'Melden dat je klaar bent.
MsgBox "Alle data verwerkt.", vbInformation, "Klaar"
End Sub

Bekijk bijlage HelpMijRapportagekalender.xlsm

Veel Succes

 

[vriestimeos]

Elsendoorn 2134, bedankt. Super!