Extra kolom en regels toevoegen aan personeelsbestand

Uit ons HRM-systeem kan ik een export draaien van onze medewerkers, met informatie zoals o.a. contract vanaf en t/m, kostendrager, -plaats, fte(deeltijdfactor). Hieronder zie je een verkorte versie van dit bestand met fictieve namen.



Nu wil ik graag een rapport maken waarin ik kan zien of wij in de toekomst nog voldoende fte's in dienst hebben. Echter ontbreekt in het bestand een 'peildatum', waardoor ik geen relatie kan leggen op maandbasis. Ik wil graag een bestand waarbij iedere voor iedere medewerker een regels worden toegevoegd. Het aantal regels dat moet worden toegevoegd is gelijk aan het aantal maanden van begin contract tot einde contract. Indien het veld Contract t/m niet gevuld is dan heeft iemand een contract voor onbepaalde tijd. In dit geval graag regels toevoegen tot en met 31-12-2025. Het moet zo iets worden als onderstaand.




Ik heb dit zelf proberen te maken, maar het lukt mij niet. Kan iemand mij (op weg) helpen?

Bijgaand een verkort Excel bestand met fictieve namen.

Kan je toch vrij eenvoudig met een formule en filter realiseren?

VenA zei:

Kan je toch vrij eenvoudig met een formule en filter realiseren?

Klik om te vergroten...

Dat is niet wat ik zoek. Ik wil namelijk in PowerBI een rapport maken, waarmee ik in de matrix de maanden kan zetten. En daaronder de waardes van het aantal FTE's voor die betreffende maand(en) kan laten zien.

Dan moet je even een macro maken die het gaat opsplitsen.

VenA zei:

Dan moet je even een macro maken die het gaat opsplitsen.

Klik om te vergroten...

Dat was ik van plan, maar dat lukt mij niet. Hoop dat iemand mij op weg kan helpen.

Een optie

VenA zei:

Een optie

Code:

Sub VenA()
  e = 46022 '31-12-2025
  ar = Sheets("Blad1").ListObjects(1).DataBodyRange
  ReDim ar1(11, 0)
  For j = 1 To UBound(ar)
      For jj = 0 To DateDiff("m", ar(j, 5), e)
      y = Application.EDate(ar(j, 5), jj)
        If ar(j, 5) <= y And (ar(j, 4) >= y Or ar(j, 4) = "") Then
          For jjj = 0 To 10
            Select Case jjj
              Case 3, 4, 6
                ar1(jjj, t) = Format(ar(j, jjj + 1), "m-d-yyyy")
              Case Else
                ar1(jjj, t) = ar(j, jjj + 1)
            End Select
          Next jjj
          ar1(11, t) = y - 1
          t = t + 1
        ReDim Preserve ar1(11, t)
        End If
      Next jj
  Next j
  Sheets("voorbeeld").Cells(1, 15).Resize(t, 12) = Application.Transpose(ar1)
End Sub

Klik om te vergroten...

Hartstikke bedankt. Heb hem nog iets aangepast, maar dit is wat ik zocht!

Het quoten lijkt mij overbodig. Wat heb je aangepast dan? Want volgens mij werkt het niet geheel correct.

Werkt inderdaad nog niet helemaal correct. Hij neemt de laatste contractmaand niet mee. Daar heb ik nog niks op gevonden.

Wat ik aangepast heb is dat het eerste resultaat gelijk in cel A1 komt ipv in kolom 15.