create workbooks based on a given template using data in a table

[LinTruthy]

an example of data I have on sheet two
Name bio Chem phy lug
John 40 60 50 20
Luke 70 50 30 77
Eric 80 90 89 60
I want to create a workbook per name using a template on sheet one . The name should be in c11, bio score in D17, phy score in d 18, Chem score in d19 ..., each workbook name should correspond to the name in c 11. and the workbooks saved in c :\ reports \ .

[Paul_Hossler]

Try this




Option Explicit
Sub MakeStudentBooks()
Dim wbTeacher As Workbook, wbStudent As Workbook
Dim wsTemplate As Worksheet, wsGrades As Worksheet
Dim rGrades As Range
Dim iStudent As Long
Dim sStudentWorkbook As String

'set variables
Set wbTeacher = ThisWorkbook
Set wsTemplate = Worksheets("Sheet1")
Set wsGrades = Worksheets("Sheet2") ' use better names
Set rGrades = wsGrades.Cells(1, 1).CurrentRegion


Application.ScreenUpdating = False


'go down student list, skip header in row 1
For iStudent = 2 To rGrades.Rows.Count

wsTemplate.Range("C11").Value = rGrades.Cells(iStudent, 1).Value
wsTemplate.Range("D17").Value = rGrades.Cells(iStudent, 2).Value
wsTemplate.Range("D18").Value = rGrades.Cells(iStudent, 3).Value
wsTemplate.Range("D19").Value = rGrades.Cells(iStudent, 4).Value
wsTemplate.Range("D20").Value = rGrades.Cells(iStudent, 5).Value

'copy template to new workbook
wsTemplate.Copy

'remember the new workbook which is now active
Set wbStudent = ActiveWorkbook

' sStudentWorkbook = "C:\Reports\" & rGrades.Cells(iStudent, 1).Value & ".xlsx"
sStudentWorkbook = "C:\Users\Daddy\Documents\Reports\" & rGrades.Cells(iStudent, 1).Value & ".xlsx"

'delete it if it exists, continue if it doesn't
On Error Resume Next
Kill sStudentWorkbook
On Error GoTo 0

'save with student name
wbStudent.SaveAs Filename:=sStudentWorkbook, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

wbTeacher.Activate

Next iStudent

wsTemplate.Range("C11").ClearContents
wsTemplate.Range("D17").ClearContents
wsTemplate.Range("D18").ClearContents
wsTemplate.Range("D19").ClearContents
wsTemplate.Range("D20").ClearContents
Application.ScreenUpdating = True

End Sub

[LinTruthy]

works great. thnx so much