Automatisch opslaan middels macro / vba-knop

[wernervanstrien]

Bekijk bijlage UrenOpmaak.xlsm

Beste gene die het weten,

Ik heb een bestand erbij gedaan. Daarin filter ik steeds een persoon en een week. Dit wordt het urenbriefje van een persoon. Is er een knop te verzinnen / of macro, of VBA-iets, waarmee ik op basis van weeknummer en naam werknemer uit het formulier automatisch met die combinatie een werkbriefje / urenbriefje opsla op een vaste plek?

Graag reactie,

Werner

 

[Elsendoorn2134]

Werner,

Hierbij een voorbeeld, ik heb eerst de tabel gesorteerd op naam, week, datum, begintijd.
Daarna heb ik een van de namen moeten aanpassen ik heb Bart v/d Hurk veranderd in Bart van de Hurk.
Als je namelijk Bart v/d Hurk gebruikt als naam van het bestand gaat hij vreemde dingen doen met de "/".
Daarna heb ik een macro geschreven die de tabel splitst in de verschillende bestanden.

Public Sub SplitsBestand()

Dim sNaam As String
Dim nWeeknr As Integer
Dim lRegel As Long
Dim lTeller As Long
Dim nBestandTeller As Integer

'Loop door gehele lijst
With Workbooks("HelpmijUrenbriefjes.xlsm").Sheets("Blad1").Range("A2")
    Do While .Offset(lRegel, 0) <> ""
        sNaam = .Offset(lRegel, 0)
        nWeeknr = .Offset(lRegel, 2)
        'Maak een nieuw bestand
        Workbooks.Add
        'Kopieer de kop regel
        .Offset(-1, 0).Resize(1, 13).Copy _
            Destination:=ActiveWorkbook.Sheets("Blad1").Range("A1")
        'Kopieer regels zolang snaam = huidige naam en nweeknr = huidigeweek.
        Do While sNaam = .Offset(lRegel, 0) And nWeeknr = .Offset(lRegel, 2)
            .Offset(lRegel, 0).Resize(1, 13).Copy _
                Destination:=ActiveWorkbook.Sheets("Blad1").Range("A2").Offset(lTeller, 0)
            lTeller = lTeller + 1
            lRegel = lRegel + 1
        Loop
        'Bestand is klaar, opslaan met naam en weeknummer als omschrijving.
        ActiveWorkbook.SaveAs Workbooks("HelpmijUrenbriefjes.xlsm").Path & _
            "\" & sNaam & "-" & Format(nWeeknr, "00") & ".xlsx"
        nBestandTeller = nBestandTeller + 1
        ActiveWorkbook.Close    'Sluiten bestand
        lTeller = 0
    Loop
End With
'Melden dat je klaar bent
MsgBox "Er zijn " & nBestandTeller & " bestanden aangemaakt.", _
    vbInformation, "Klaar"
End Sub

Bekijk bijlage HelpMijUrenBriefjes.xlsm


Veel Succes.

 

[wernervanstrien]

Elsendoorn,

DAnk!

Is het ook mogelijk om de afzonderlijke uren die dan per week naar voren komen op te tellen en er een weektotaal aan uren aan toe te voegen?

Graag reactie. Nogmaals dank voor de code!

W

 

[Elsendoorn2134]

Werner,

Als je de afzonderlijke uren wil optellen dan moet je de volgende twee regels opnemen vlak voor dat het bestand wordt opgeslagen:

        'Lijst is klaar, totalen invullen.
        ActiveWorkbook.Sheets("Blad1").Range("J2").Offset(lTeller + 1, -1) = "Totaal"
        ActiveWorkbook.Sheets("Blad1").Range("J2").Offset(lTeller + 1, 0) = "=SUM($J$2:$J$" & lTeller + 2 & ")"
        'Bestand is klaar, opslaan met naam en weeknummer als omschrijving.

Veel Succes.