Macro to populate weeks and rows on multiple sheets

zzHawkzz

New Member
Joined
Nov 25, 2015
Messages
12
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)

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
[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]11/15/2015
[/TD]
[TD]xxx
[/TD]
[TD]xxx
[/TD]
[/TR]
[TR]
[TD]11/22/2015
[/TD]
[TD]xxx
[/TD]
[TD]xxx
[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited by a moderator:

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
In the long sub FillOutTemplate about three quarters down you will find the line. Here the sub, after filling out the values in the template, calls the function CreateWeeks and passes it the start and end dates, and the sheet on which these are to be placed.

the first time I sent you the code I had a typo and the start and end dates were the same, when you correct it the dates are the real start and end dates, so now it should insert the lines for each week.
 
Upvote 0
Got it! It worked. Just having a problem with the formatting. Anyway to get it to copy the formatting all the way down with out having to do it manually?

Thanks for your help
 
Upvote 0
If row 23 is formatted correctly than the new inserted rows should take over the same formatting. is this not happening?
 
Upvote 0
could you post a workbook with just the template sheet somewhere (dropbox for instance)? Then I can have a look why that is not happening and set up the coding for the formatting.
 
Upvote 0
OK I'll have a look at it, but it might not be before Wednesday
 
Upvote 0
That's great. If you could repost a link to the file so I can download it, like we did here, I'd appreciate it.
 
Upvote 0

Forum statistics

Threads
1,223,262
Messages
6,171,080
Members
452,377
Latest member
bradfordsam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top