Uren invullen op kalander en verwerken naar lijst

[5t3f4n]

Hallo,

Ik ben bezig met het maken van een urenregistratie formulier.

Bekijk bijlage invul kalander naar lijst.xlsx

Dit formulier wordt gebuikt door meerdere medewerkers. Iedere medewerker heeft een eigen tab met een kalander.
In het voorbeeld heb ik er slecht twee medewerkers gezet, maar het kunnen er meer zijn.

In de kalander staan de dagen in de kolommen en de projecten op de rijen. De medewerker moet per dag het aantal uur opgeven dat er gewerkt is aan een project en het werkzaamheden die zijn uitgevoerd.

In de tab "lijst" wil ik een overzicht hebben van alle medewerkers, met alle werkzaamheden en uren. Uiteindelijk wil ik kunnen filteren per project, medewerker en werkzaamheden om te bekijken hoeveel uren hieraan zijn besteed.

Is er een snelle manier om deze lijst te maken zonder witte regels ertussen? In het voorbeeld heb ik de lijst gemaakt door direct te verwijzen naar de ingevulde cellen, maar dit is natuurlijk niet erg handig!

Kan iemand mij op weg helpen? Alvast bedankt

Stefan

 

[snb]

Heb je outlook al eens bekeken ?
Die bevat een agenda die hetzelfde doet als jouw kalender.

 

[popipipo]

Is een draaitabel misschien een optie
Maar wat wil je precies bereiken?
365 dagen à 2 kolommen zijn ruim 700 kolommen wat naar mijn mening niet echt overzichtelijk is.

 

[VenA]

Als je voor deze opzet gekozen hebt is het wel op te lossen. En kan waarschijnlijk beter:d

Sub VenA()
With Sheets("Lijst")
    .Cells.Delete
    .Cells(1).Resize(1, 5) = Array("Naam", "Datum", "Project", "Werkzaamheden", "Uren")
    For Each sh In Sheets
        t = 0
        If sh.Name <> "Lijst" Then
            ar1 = sh.Cells(1).CurrentRegion
            ReDim ar2(UBound(ar1, 2), 4)
            For j = 3 To UBound(ar1)
                For jj = 2 To UBound(ar1, 2) Step 2
                    If ar1(j, jj) <> "" Then
                        ar2(t, 0) = ar1(1, 1)
                        ar2(t, 1) = ar1(1, jj)
                        ar2(t, 2) = ar1(j, 1)
                        ar2(t, 3) = ar1(j, jj)
                        ar2(t, 4) = ar1(j, jj + 1)
                        t = t + 1
                    End If
                Next jj
            Next j
            .Cells(.Cells(1).CurrentRegion.Rows.Count + 1, 1).Resize(UBound(ar2), 5) = ar2
        End If
    Next sh
    .ListObjects.Add(xlSrcRange, .Cells(1).CurrentRegion, , xlYes).Name = "TblLijst"
End With
End Sub

Als je op de tab 'Lijst' klikt wordt de tabel automatisch gemaakt.

 

[HSV]

Of in één schrijfbeweging.

Sub VenA_hsv()
With Sheets("Lijst")
    .Cells.Delete
    .Cells(1).Resize(1, 5) = Array("Naam", "Datum", "Project", "Werkzaamheden", "Uren")
 For Each sh In Sheets
        a = sh.UsedRange.Rows.Count
          If b < a Then b = a
       Next sh
    ReDim ar2(b * Sheets.Count, 4)
    For Each sh In Sheets
        If sh.Name <> "Lijst" Then
            ar1 = sh.Cells(1).CurrentRegion
              For j = 3 To UBound(ar1)
                For jj = 2 To UBound(ar1, 2) Step 2
                    If ar1(j, jj) <> "" Then
                        ar2(t, 0) = ar1(1, 1)
                        ar2(t, 1) = ar1(1, jj)
                        ar2(t, 2) = ar1(j, 1)
                        ar2(t, 3) = ar1(j, jj)
                        ar2(t, 4) = ar1(j, jj + 1)
                        t = t + 1
                    End If
                Next jj
            Next j
            
        End If
    Next sh
    .Cells(2, 1).Resize(t, 5) = ar2
    .ListObjects.Add(xlSrcRange, .Cells(1).CurrentRegion, , xlYes).Name = "TblLijst"
End With
End Sub