Create Worksheet based on datasheet and template

[vivpr]

[FONT=&quot]Hi,[/FONT]
[FONT=&quot]I have a datasheet and a template. I need to create around 30 worksheets(in the same workbook) using the data . When I run the macro with 7 sets of data it is working fine (execution time: 3 minutes). But it is hanging if I enter more number of data.

Please find the code I am using
[/FONT][FONT=&quot]Option Explicit[/FONT]


[FONT=&quot]Sub PTOTemplateFill()[/FONT]


[FONT=&quot]Dim LastRw As Long, Rw As Long, Cnt As Long[/FONT]
[FONT=&quot]Dim dSht As Worksheet, tSht As Worksheet[/FONT]
[FONT=&quot]Dim MakeBooks As Boolean, SavePath As String[/FONT]


[FONT=&quot]Application.ScreenUpdating[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot] = False 'speed up macro execution[/FONT]
[FONT=&quot]Application.DisplayAlerts = False 'no alerts, default answers used[/FONT]



[FONT=&quot]Set dSht = Sheets("Datasheet") 'sheet with data on it starting in row2[/FONT]
[FONT=&quot]Set tSht = Sheets("Project Page Template") 'sheet to copy and fill out[/FONT]

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

[FONT=&quot]If MakeBooks Then 'select a folder for the new workbooks[/FONT]
[FONT=&quot] MsgBox "Please select a destination for the new workbooks"[/FONT]
[FONT=&quot] Do[/FONT]
[FONT=&quot] With Application.FileDialog(mso[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]FileDialog[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]FolderPick[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]er)[/FONT]
[FONT=&quot] .AllowMultiSelect = False[/FONT]
[FONT=&quot] .Show[/FONT]
[FONT=&quot] If .SelectedItems.Count > 0 Then 'a folder was chosen[/FONT]
[FONT=&quot] SavePath = .SelectedItems(1) & "\"[/FONT]
[FONT=&quot] Exit Do[/FONT]
[FONT=&quot] Else 'a folder was not chosen[/FONT]
[FONT=&quot] If MsgBox("Do you wish to abort?", _[/FONT]
[FONT=&quot] vbYesNo + vbQuestion) = vbYes Then Exit Sub[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] End With[/FONT]
[FONT=&quot] Loop[/FONT]
[FONT=&quot]End If[/FONT]

[FONT=&quot]'Determine last row of data then loop through the rows one at a time[/FONT]
[FONT=&quot] LastRw = dSht.Range("P" & Rows.Count).End(xlUp).Row[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] For Rw = 2 To LastRw[/FONT]
[FONT=&quot] tSht.Copy After:=Worksheets(Workshee[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]ts.Count) 'copy the template[/FONT]
[FONT=&quot] With ActiveSheet 'fill out the form[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] .Name = dSht.Range("P" & Rw)[/FONT]
[FONT=&quot] .Range("AU1").Value = dSht.Range("P" & Rw).Value[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Physical Progress[/FONT]
[FONT=&quot] .Range("L61:P61").Value = dSht.Range("AG" & Rw).Value[/FONT]
[FONT=&quot] .Range("L62:P62").Value = dSht.Range("AH" & Rw).Value[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Financial Progress[/FONT]
[FONT=&quot] .Range("L66:P66").Value = dSht.Range("AD" & Rw).Value[/FONT]
[FONT=&quot] .Range("L67:P67").Value = dSht.Range("AC" & Rw).Value[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Contract Status[/FONT]
[FONT=&quot] .Range("AC60:AG60").Value = dSht.Range("W" & Rw).Value[/FONT]
[FONT=&quot] .Range("AC62:AG62").Value = dSht.Range("Y" & Rw).Value[/FONT]
[FONT=&quot] .Range("AC63:AG63").Value = dSht.Range("AK" & Rw).Value[/FONT]
[FONT=&quot] .Range("AC64:AG64").Value = dSht.Range("AL" & Rw).Value[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Contract No[/FONT]
[FONT=&quot] .Range("AC66:AG66").Value = dSht.Range("O" & Rw).Value[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Title[/FONT]
[FONT=&quot] .Range("CI12").Value = dSht.Range("P" & Rw).Value[/FONT]
[FONT=&quot] .Range("CI13").Value = dSht.Range("Q" & Rw).Value[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Summary[/FONT]
[FONT=&quot] .Range("L22:Z38").Value = dSht.Range("BL" & Rw).Value[/FONT]
[FONT=&quot] .Range("L41:Z57").Value = dSht.Range("BM" & Rw).Value[/FONT]
[FONT=&quot] .Range("AD23:AN31").Value = dSht.Range("BN" & Rw).Value[/FONT]
[FONT=&quot] .Range("AD49:AN57").Value = dSht.Range("BO" & Rw).Value[/FONT]
[FONT=&quot] End With[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] If MakeBooks Then 'if making separate workbooks from filled out form[/FONT]
[FONT=&quot] ActiveSheet.Move[/FONT]
[FONT=&quot] ActiveWorkbook.SaveAs SavePath & Range("AU1").Value, xlNormal[/FONT]
[FONT=&quot] ActiveWorkbook.Close False[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] Cnt = Cnt + 1[/FONT]
[FONT=&quot] Next Rw[/FONT]

[FONT=&quot] dSht.Activate[/FONT]
[FONT=&quot] If MakeBooks Then[/FONT]
[FONT=&quot] MsgBox "Workbooks created: " & Cnt[/FONT]
[FONT=&quot] Else[/FONT]
[FONT=&quot] MsgBox "Worksheets created: " & Cnt[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]Application.ScreenUpdating[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot] = True[/FONT]

[FONT=&quot]End Sub[/FONT]

[FONT=&quot]--------------------------[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]----------[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]----------[/FONT]<wbr style="font-size: 16px; font-family: "Open Sans", sans-serif;">[FONT=&quot]--[/FONT][FONT=&quot]
[/FONT]