Vba code to create multiple copies for a said template

[Jagdev Singh]

Hi Experts,

I have a payment voucher template saved in a location is it possible to create number of copies (Sheets) of the template with the voucher number provided in the second sheet of the attached template. Each sheet should have unique voucher number.

Regards,

JD

 

[Chihiro]

Something like this?

Sub CopyTemplate()
Dim lRow As Integer
Dim cel As Range
Dim ws As Worksheet, oWs As Worksheet, rWs As Worksheet

Application.ScreenUpdating = False

Set oWs = ThisWorkbook.Sheets("Sheet1")
Set rWs = ThisWorkbook.Sheets("Sheet2")

lRow = rWs.Range("A" & Rows.Count).End(xlUp).Row
   
    For Each cel In rWs.Range("A1:A" & lRow)
        oWs.Copy After:=ThisWorkbook.Sheets(Sheets.Count)
        Set ws = ThisWorkbook.Sheets(Sheets.Count)
      ws.Name = cel.Value
    Next cel
Application.ScreenUpdating = True
End Sub

 

[Jagdev Singh]

Hi Chihiro,

Awesome way of dealing with this. Thanks a lot for the above code. I will try to match it with my real set of data and will get back to you.

Regards,
JD

 

[Jagdev Singh]

Hi Experts,

I need your help to deal with the above request further. I have attached a copy of the template and data in separate tab. The vba code to run and create a separate copy filling the information available in a separate tab in the sheet named "Table" and saved the copies in a folder.

Regards,
JD

 

[Jagdev Singh]

Hi Experts,

Any views on the below amendments.

Regards
JD

 

[Deepak]

Sub CopyTemplate2()
Dim lRow As Integer
Dim cel As Range
Dim ws As Worksheet, oWs As Worksheet, rWs As Worksheet
Dim strPath As String

Application.ScreenUpdating = False

strPath = "C:\ABC\XYZ"

If Not Dir(strPath) <> "" Then MsgBox "Path not found!", vbCritical: Exit Sub

If Not Right(strPath, 1) <> "\" Then strPath = strPath & "\"

Set oWs = ThisWorkbook.Sheets("Table 1")
Set rWs = ThisWorkbook.Sheets("Sheet1")

lRow = rWs.Range("A" & Rows.Count).End(xlUp).Row
    For Each cel In rWs.Range("A2:A" & lRow)
        oWs.[I6].Value = cel.Value
        oWs.[I7].Value = cel.Offset(, 1).Value
        oWs.Copy
        ActiveWorkbook.SaveAs Filename:=strPath & cel.Offset(, 2).Value
        ActiveWindow.Close
    Next cel
 
    oWs.[I6].Value = ""
    oWs.[I7].Value = ""
Application.ScreenUpdating = True

End Sub

 

[Jagdev Singh]

Thanks Again Deepak for the above code!

You are a champ and genius!

Regards,
JD

 

[Deepak]

Jd,

Here's a silly mistake.

Remove not from the below line.

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

Sorry for the same.