coolworld
09-13-2016, 03:06 AM
Hello,
I am delighted to use the forum for the first time.
I encounter an issue with my excel vba function.
Not being a coder, I went online looking for some vba code that would allow me to "print" a template version ("Template" spreadsheet) of the rows info filled on a first sheet ("Main" spreadsheet).
So I found something. that works.
Here is the code :
Sub FillOutTemplate()
response = MsgBox("Are you sure you want to save ?", vbYesNo)
If response = vbNo Then
MsgBox ("Operation cancelled.")
Exit Sub
End If
rspn = InputBox("Please enter password")
If rspn <> "secret" Then
MsgBox "Operation cancelled."
Exit Sub
End If
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("Main") 'sheet with data on it starting in row4
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 to save the Personal Information Templates"
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 = 4 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("F" & Rw)
.Range("E1").Value = dSht.Range("A" & Rw).Value
.Range("B2").Value = dSht.Range("F" & Rw).Value
.Range("C2").Value = dSht.Range("G" & Rw).Value
.Range("E2").Value = dSht.Range("E" & Rw).Value
.Range("D4").Value = dSht.Range("F" & Rw).Value
.Range("D6").Value = dSht.Range("G" & Rw).Value
.Range("D8").Value = dSht.Range("H" & Rw).Value
.Range("D9").Value = dSht.Range("I" & Rw).Value
.Range("D11").Value = dSht.Range("J" & Rw).Value
.Range("D12").Value = dSht.Range("K" & Rw).Value
.Range("D13").Value = dSht.Range("L" & Rw).Value
.Range("D15").Value = dSht.Range("M" & Rw).Value
.Range("D16").Value = dSht.Range("N" & Rw).Value
.Range("D17").Value = dSht.Range("O" & Rw).Value
.Range("D19").Value = dSht.Range("P" & Rw).Value
.Range("D20").Value = dSht.Range("Q" & Rw).Value
.Range("D21").Value = dSht.Range("R" & Rw).Value
.Range("D23").Value = dSht.Range("S" & Rw).Value
.Range("D24").Value = dSht.Range("T" & Rw).Value
.Range("D25").Value = dSht.Range("U" & Rw).Value
.Range("D26").Value = dSht.Range("V" & Rw).Value
.Range("D27").Value = dSht.Range("W" & Rw).Value
.Range("D28").Value = dSht.Range("X" & Rw).Value
.Range("D29").Value = dSht.Range("Y" & Rw).Value
.Range("D31").Value = dSht.Range("Z" & Rw).Value
.Range("D32").Value = dSht.Range("AA" & Rw).Value
.Range("D34").Value = dSht.Range("AB" & Rw).Value
.Range("D36").Value = dSht.Range("AC" & Rw).Value
End With
If MakeBooks Then 'if making separate workbooks from filled out form
ActiveSheet.Move
ActiveWorkbook.SaveAs SavePath & Range("E2").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
There are two things I would like to fix,
1) How to delete the option of choosing between saving all the templates in the same workbook ?? I would like that the only option is to save the templates in separate workbooks.
("YES = template will be copied to separate workbooks." & vbLf & _
"NO = template will be copied to sheets within this same workbook", _)
2) How to instead of generating multiple workbooks, it would generate multiple PDF ? Is there a lot to do to adapt the code ?
Many thanks in advance!
I am delighted to use the forum for the first time.
I encounter an issue with my excel vba function.
Not being a coder, I went online looking for some vba code that would allow me to "print" a template version ("Template" spreadsheet) of the rows info filled on a first sheet ("Main" spreadsheet).
So I found something. that works.
Here is the code :
Sub FillOutTemplate()
response = MsgBox("Are you sure you want to save ?", vbYesNo)
If response = vbNo Then
MsgBox ("Operation cancelled.")
Exit Sub
End If
rspn = InputBox("Please enter password")
If rspn <> "secret" Then
MsgBox "Operation cancelled."
Exit Sub
End If
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("Main") 'sheet with data on it starting in row4
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 to save the Personal Information Templates"
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 = 4 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("F" & Rw)
.Range("E1").Value = dSht.Range("A" & Rw).Value
.Range("B2").Value = dSht.Range("F" & Rw).Value
.Range("C2").Value = dSht.Range("G" & Rw).Value
.Range("E2").Value = dSht.Range("E" & Rw).Value
.Range("D4").Value = dSht.Range("F" & Rw).Value
.Range("D6").Value = dSht.Range("G" & Rw).Value
.Range("D8").Value = dSht.Range("H" & Rw).Value
.Range("D9").Value = dSht.Range("I" & Rw).Value
.Range("D11").Value = dSht.Range("J" & Rw).Value
.Range("D12").Value = dSht.Range("K" & Rw).Value
.Range("D13").Value = dSht.Range("L" & Rw).Value
.Range("D15").Value = dSht.Range("M" & Rw).Value
.Range("D16").Value = dSht.Range("N" & Rw).Value
.Range("D17").Value = dSht.Range("O" & Rw).Value
.Range("D19").Value = dSht.Range("P" & Rw).Value
.Range("D20").Value = dSht.Range("Q" & Rw).Value
.Range("D21").Value = dSht.Range("R" & Rw).Value
.Range("D23").Value = dSht.Range("S" & Rw).Value
.Range("D24").Value = dSht.Range("T" & Rw).Value
.Range("D25").Value = dSht.Range("U" & Rw).Value
.Range("D26").Value = dSht.Range("V" & Rw).Value
.Range("D27").Value = dSht.Range("W" & Rw).Value
.Range("D28").Value = dSht.Range("X" & Rw).Value
.Range("D29").Value = dSht.Range("Y" & Rw).Value
.Range("D31").Value = dSht.Range("Z" & Rw).Value
.Range("D32").Value = dSht.Range("AA" & Rw).Value
.Range("D34").Value = dSht.Range("AB" & Rw).Value
.Range("D36").Value = dSht.Range("AC" & Rw).Value
End With
If MakeBooks Then 'if making separate workbooks from filled out form
ActiveSheet.Move
ActiveWorkbook.SaveAs SavePath & Range("E2").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
There are two things I would like to fix,
1) How to delete the option of choosing between saving all the templates in the same workbook ?? I would like that the only option is to save the templates in separate workbooks.
("YES = template will be copied to separate workbooks." & vbLf & _
"NO = template will be copied to sheets within this same workbook", _)
2) How to instead of generating multiple workbooks, it would generate multiple PDF ? Is there a lot to do to adapt the code ?
Many thanks in advance!