VBA help required: Creating multiple workbooks from a template and a list of names

[CarolynL]

Hopefully someone smarter than me can provide me with a neat VBA macro that will do the following;

The easiest way I can describe the scenario I am trying to create, is to use a company list of personnel (my index) and to generate a time-sheet workbook per person based on a pre-populated template. This time-sheet is saved as the persons name and has the persons name entered into cell D:10

I have a workbook which contains two worksheets;
1) An Index sheet which contains a list of names that I wish to use in Q16 downwards (note the length of this list will vary each time I run this)
2) A "template" sheet which I wish to duplicate in new workbooks
3) A second "data" sheet that I wish to copy across in new workbooks


I need a macro that will take the "template" and "data" sheets and copy it into a new workbook, renaming each new workbook to each name in my Index sheet. I also want that same Name to be copied into cell reference D:10 of the "template" each time.

The end result is that I should have a series of new files generated and saved which are named the same as the Index list, with both the "Template" sheet and the "Data" sheet present, with the cell D:10 pre-populated with the Name provided in the "Template" sheet.

For ease, I'll save these into My Documents for now. (If you need that info?)

I'm using Excel 2010, and have some knowledge of macros through using these forums for help, however I'm still a newbie so this one is making my head spin!

I hope that makes sense.

 

[JLGWhiz]

All sheet names should be edited for accuracy. See if this will work.

Sub create()
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("Index") 'Edit sheet name
Set sh2 = Sheets("Data") 'Edit sheet name
lr = sh.Cells(Rows.Count, "Q").End(xlUp).Row
Set rng = sh.Range("Q16:Q" & lr)
    For Each c In rng
        Set wb = Sheets("Template").Copy 'Edit sheet name
        wb.Sheets(1).Range("D10") = c.Value
        sh2.Copy After:=wb.Sheets(1)
        wb.SaveAs c.Value & ".xlsx"
        wb.Close False
    Next
End Sub

 

[CarolynL]

It looks like it might work, however its bugging at this point and I'm not sure why? Says object required;

Sub create()
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("Index") 'Edit sheet name
Set sh2 = Sheets("Data") 'Edit sheet name
lr = sh1.Cells(Rows.Count, "Q").End(xlUp).Row
Set rng = sh1.Range("Q16:Q" & lr)
    For Each c In rng
[U][B]        Set wb = Sheets("Template").Copy 'Edit sheet name[/B][/U]
        wb.Sheets(1).Range("D10") = c.Value
        sh2.Copy After:=wb.Sheets(1)
        wb.SaveAs c.Value & ".xlsx"
        wb.Close False
    Next
End Sub

Thanks,
Carolyn

 

[sheetspread]

If the sheet you call "Template" has a different name be sure it matches what's on that line.

 

[CarolynL]

If the sheet you call "Template" has a different name be sure it matches what's on that line.

All the sheet names are correct in the macro - it still doesn't seem to be working

 

[JLGWhiz]

Try it this way.

Sub create()
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("Index") 'Edit sheet name
Set sh2 = Sheets("Data") 'Edit sheet name
lr = sh1.Cells(Rows.Count, "Q").End(xlUp).Row
Set rng = sh1.Range("Q16:Q" & lr)
    For Each c In rng
        Sheets("Template").Copy 'Edit sheet name
        Set wb = ActiveWorkbook
        wb.Sheets(1).Range("D10") = c.Value
        sh2.Copy After:=wb.Sheets(1)
        wb.SaveAs c.Value & ".xlsx"
        wb.Close False
    Next
End Sub

 

[CarolynL]

Try it this way.

That worked fantastically. Thank-you very much!

 

[JLGWhiz]

That worked fantastically. Thank-you very much!

You're welcome
Regards, JLG

 

[PATTANAM]

Hello All,
I have red above posting and I require your help to similar requirement as below mentioned.

I have mentioned like many company codes and one workbook is created (xyz) with full of details as requirement.

My requirement is that which is already created (xyz) with full of details same files/workbooks to be created (new/Save As) as much as I have given company codes but here company code may be varies.

Criteria-1 : While creating files each file name should each company code (one by one).

Criteria-2 : Once it creates files with each company code same company code details should be updated in Range ("A15") in each file company code workbooks.

Company Code
GR00
HU00
IE00
IL10
IT40

 

[sheetspread]

If the company codes are in A2:A6 of the tab named "Data", this will create new workbooks with them as the filename and cell A15 value:

Sub wkbksfromlist()
Dim x%, lr%
Dim wbname As String
Dim wbnew As Workbook
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lr
wbname = ThisWorkbook.Sheets("Data").Range("A" & x).Value
Set wbnew = Workbooks.Add()
wbnew.SaveAs Filename:="C:\Users\myname\Desktop\" & wbname & ".xlsx"
With ActiveWorkbook
.Sheets("sheet1").Range("A15").Value = wbname
.Close SaveChanges:=True
End With
Next
End Sub