Macro to populate weeks and rows on multiple sheets

[zzHawkzz]

Good Day,

I am currently working in a workbook which uses a macro. The Macro uses information input on a Data Sheet and a Template to populate any number of spreadsheets based on the data populated on the Data Sheet. This is very useful; however, I am also in need of modifying or using a new macro which will take the start and end dates and populate the number of rows on the automatically populated spreadsheets based on the number of weeks between the start and end date. I also need the rows populated (starting at A23) with the week ending date. The tricky part is The week may end on any day of the week. So the date ending might start on a Monday and End on a Sunday, or Saturday to Friday ETC. I will paste the Macro I am using (VB CODE)

Option Explicit

Sub FillOutTemplate()
'Jerry Beaucaire  4/25/2010
'From Sheet1 data fill out template on sheet2 and save
'each sheet as its own file.
Dim LastRw As Long, Rw As Long, Cnt As Long
Dim dSht As Worksheet, tSht As Worksheet
Dim MakeBooks As Boolean, SavePath As String

Application.ScreenUpdating = False  'speed up macro execution
Application.DisplayAlerts = False   'no alerts, default answers used

Set dSht = Sheets("Data")           'sheet with data on it starting in row2
Set tSht = Sheets("Template")       'sheet to copy and fill out

'Option to create separate workbooks
    MakeBooks = MsgBox("Create separate workbooks?" & vbLf & vbLf & _
        "YES = template will be copied to separate workbooks." & vbLf & _
        "NO = template will be copied to sheets within this same workbook", _
            vbYesNo + vbQuestion) = vbYes

If MakeBooks Then   'select a folder for the new workbooks
    MsgBox "Please select a destination for the new workbooks"
    Do
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count > 0 Then    'a folder was chosen
                SavePath = .SelectedItems(1) & "\"
                Exit Do
            Else                                'a folder was not chosen
                If MsgBox("Do you wish to abort?", _
                    vbYesNo + vbQuestion) = vbYes Then Exit Sub
            End If
        End With
    Loop
End If

'Determine last row of data then loop through the rows one at a time
    LastRw = dSht.Range("A" & Rows.Count).End(xlUp).Row
    
    For Rw = 2 To LastRw
        tSht.Copy After:=Worksheets(Worksheets.Count)   'copy the template
        With ActiveSheet                                'fill out the form
            'edit these rows to fill out your form, add more as needed
            .Name = dSht.Range("B" & Rw) & ", " & dSht.Range("C" & Rw) 'Sheet Name
            '.Range("b17").Value = dSht.Range("n" & Rw).Value 'Start Time
            .Range("A5").Value = dSht.Range("A" & Rw).Value 'Establishment
            .Range("a8").Value = dSht.Range("c" & Rw).Value & ", " & dSht.Range("B" & Rw).Value 'Name
            .Range("a11").Value = dSht.Range("d" & Rw).Value 'Address
            .Range("f11").Value = dSht.Range("e" & Rw).Value 'City
            .Range("g11").Value = dSht.Range("f" & Rw).Value 'State
            .Range("h11").Value = dSht.Range("g" & Rw).Value 'Zip Code
            .Range("a14").Value = dSht.Range("j" & Rw).Value 'Position
            .Range("f14").Value = dSht.Range("h" & Rw).Value 'Start Date Employment
            .Range("h14").Value = dSht.Range("i" & Rw).Value    'End Date Employement
            .Range("b18").Value = dSht.Range("k" & Rw).Value    'Rate of Pay
            '.Range("D5:D7").Value = dSht.Range("C" & Rw, "E" & Rw).Value
        End With
        
        If MakeBooks Then       'if making separate workbooks from filled out form
            ActiveSheet.Move
            ActiveWorkbook.SaveAs SavePath & Range("a8").Value, xlNormal
            ActiveWorkbook.Close False
        End If
        Cnt = Cnt + 1
    Next Rw

    dSht.Activate
    If MakeBooks Then
        MsgBox "Workbooks created: " & Cnt
    Else
        MsgBox "Worksheets created: " & Cnt
    End If
    
Application.ScreenUpdating = True
End Sub

---

Example of What I need done: 11/10/2015 to 11/25/2015 (2wks, MON-SUN)

WEEKENDING

11/15/2015	xxx	xxx
11/22/2015	xxx	xxx

<tbody>
</tbody>

 

[sijpie]

So what does the Data sheet look like? Where are these 'start date' and 'end date'? And where on the new sheets do they need to be written?

 

[zzHawkzz]

The Data Sheet has 16 columns and as few as three rows (see DATA SHEET IMAGE)

.

The Template is where I manipulate the data Starting at A20 (see Template)

I need the red data to populate as blue data (see Template) I also need it to populate the # of rows based on the # of weeks between the two. For example the image shows 2.1 weeks, thus I need 2 rows. Thanks

~

 

[sijpie]

So from column H & I in the data sheet the Start date and End date are to be copied into F14 & H14 for the relevant template. Then the macro needs to calculate the number of weeks between these dates and fill out a row for each week starting in A23 on the Template. is that correct?

 

[zzHawkzz]

Yes sir, that is correct!

 

[sijpie]

Option Explicit




Sub FillOutTemplate()
'Jerry Beaucaire  4/25/2010
'From Sheet1 data fill out template on sheet2 and save
'each sheet as its own file.
    Dim LastRw As Long, Rw As Long, Cnt As Long
    Dim dSht As Worksheet, tSht As Worksheet
    Dim MakeBooks As Boolean, SavePath As String
    
    Application.ScreenUpdating = False  'speed up macro execution
    Application.DisplayAlerts = False   'no alerts, default answers used
    
    Set dSht = Sheets("Data")           'sheet with data on it starting in row2
    Set tSht = Sheets("Template")       'sheet to copy and fill out
    
    'Option to create separate workbooks
    MakeBooks = MsgBox("Create separate workbooks?" & vbLf & vbLf & _
        "YES = template will be copied to separate workbooks." & vbLf & _
        "NO = template will be copied to sheets within this same workbook", _
            vbYesNo + vbQuestion) = vbYes


    If MakeBooks Then   'select a folder for the new workbooks
        MsgBox "Please select a destination for the new workbooks"
        Do
            With Application.FileDialog(msoFileDialogFolderPicker)
                .AllowMultiSelect = False
                .Show
                If .SelectedItems.Count > 0 Then    'a folder was chosen
                    SavePath = .SelectedItems(1) & "\"
                    Exit Do
                Else                                'a folder was not chosen
                    If MsgBox("Do you wish to abort?", _
                        vbYesNo + vbQuestion) = vbYes Then Exit Sub
                End If
            End With
        Loop
    End If
    
    'Determine last row of data then loop through the rows one at a time
    LastRw = dSht.Range("A" & Rows.Count).End(xlUp).Row
    
    For Rw = 2 To LastRw
        tSht.Copy After:=Worksheets(Worksheets.Count)   'copy the template
        With ActiveSheet                                'fill out the form
            'edit these rows to fill out your form, add more as needed
            .Name = dSht.Range("B" & Rw) & ", " & dSht.Range("C" & Rw) 'Sheet Name
            '.Range("b17").Value = dSht.Range("n" & Rw).Value 'Start Time
            .Range("A5").Value = dSht.Range("A" & Rw).Value 'Establishment
            .Range("a8").Value = dSht.Range("c" & Rw).Value & ", " & dSht.Range("B" & Rw).Value 'Name
            .Range("a11").Value = dSht.Range("d" & Rw).Value 'Address
            .Range("f11").Value = dSht.Range("e" & Rw).Value 'City
            .Range("g11").Value = dSht.Range("f" & Rw).Value 'State
            .Range("h11").Value = dSht.Range("g" & Rw).Value 'Zip Code
            .Range("a14").Value = dSht.Range("j" & Rw).Value 'Position
            .Range("f14").Value = dSht.Range("h" & Rw).Value 'Start Date Employment
            .Range("h14").Value = dSht.Range("i" & Rw).Value    'End Date Employement
            .Range("b18").Value = dSht.Range("k" & Rw).Value    'Rate of Pay
            '.Range("D5:D7").Value = dSht.Range("C" & Rw, "E" & Rw).Value
            
            ' Create the weeks in A23 and below
            CreateWeeks .Range("f14"), .Range("f14"), ActiveSheet
        End With
        If MakeBooks Then       'if making separate workbooks from filled out form
            ActiveSheet.Move
            ActiveWorkbook.SaveAs SavePath & Range("a8").Value, xlNormal
            ActiveWorkbook.Close False
        End If
        Cnt = Cnt + 1
    Next Rw


    dSht.Activate
    If MakeBooks Then
        MsgBox "Workbooks created: " & Cnt
    Else
        MsgBox "Worksheets created: " & Cnt
    End If
    
    Application.ScreenUpdating = True
End Sub


Sub CreateWeeks(ByVal lWk1 As Long, ByVal lWk2 As Long, wsT As Worksheet)
' sub to create week rows from row 23 in the worksheet wsT _
' and enter the dates in column A


    Dim rOut As Range
    Dim lWk As Long
    
    Set rOut = wsT.Range("A23")
    lWk = lWk1
    Do While lWk <= lWk2
        rOut.Value = lWk
        rOut.Offset(1, 0).EntireRow.Insert
        Set rOut = rOut.Offset(1, 0)
        lWk = lWk + 7
    Loop
    


End Sub

I have added a sub to do the row adding and enter the dates

 

[zzHawkzz]

It didn't work. It won't even recognize the macro

 

[sijpie]

Delete your own macro and copy paste all of my code into your module. Now run your macro FillOutTemplate (not mine). Your macro will call mine when it needs to.

 

[zzHawkzz]

Yeah, it still didn't work. It only populates the first date. It doesn't populate any others nor does it populate the rows...

 

[sijpie]

oops typo:

change the line

            CreateWeeks .Range("f14"), .Range("f14"), ActiveSheet

to:

            CreateWeeks .Range("f14"), .Range("h14"), ActiveSheet