Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Sub CreateIndividualSurveyBook()
Dim i As Long, j As Long
Dim wb As workbook
Dim newBook As Workbook 'New (individual) workbook
Dim newBook_Name As String
Dim strMsg As String 'The message when the file already exists.
Dim finalRow As Long 'finds the final row of the Database sheet
Set wb = ThisWorkbook
finalRow = wb.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Row
'Enter fiscal year on the first sheet
'The other sheets refer to the first sheet
wb.Worksheets("FormA").Cells(2, 2).Value = _
"FY" & Year(Now()) & "XXX Survey - A"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To finalRow
'Input the record ID of the database sheet. (the part highlighted in yellow)
wb.Worksheets("FormA").Cells(1, 6).Value = i - 1
Set newBook = Workbooks.Add
'Copy the worksheets from the master workbook and add to the individual workbook.
'In case there are any changes in the sheet order, please revise the array.
'Alternative method: use the sheet name. e.g. Array("FormA", "FormB", ...)
wb.Worksheets(Array(4, 5)).Copy before:=newBook.Worksheets(1)
With newBook
'Activate "FormA" so that it is displayed when in opening the individual workbook.
.Worksheets(1).Activate
'Delete the unnecessary worksheet.
.Worksheets(.Worksheets.Count).Delete
'Remove the unnecessary links from the individula workbook.
Call BreakLinks_SeparateBook(newBook)
'Delete the record ID.
.Worksheets(1).Cells(1, 6).ClearContents
'Protect worksheets with Password.
For j = 1 To .Worksheets.Count
.Worksheets(j).Protect Password:="PASSWORD"
Next j
End With
'Save the file as "FYXXX XXXX Survey (officeName) staffName.xls"
'The file will be stored in the current directry. If necessary, add the folder pass.
'(ThisWorkbook.Path & "\") can be removed.
With wb.Worksheets("Database")
newBook_Name = "\FY" & _
Year(Now()) & " XXXX Survey (" & _
.Cells(i, 5).Value & ") " & _
.Cells(i, 4) & " " & _
.Cells(i, 3)
End With
If Dir(wb.Path & newBook_Name & ".xlsx") <> "" Then
strMsg = "The file already exists. Replace the file?"
If MsgBox(strMsg, vbYesNo) = vbNo Then
newBook.SaveAs Filename:=wb.Path & newBook_Name & " - copy.xlsx"
End If
End If
newBook.SaveAs Filename:=wb.Path & newBook_Name & ".xlsx"
'Close the book.
newBook.Close savechanges:=True
wb.Activate
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Survey files were generated."
End Sub
Sub BreakLinks_SeparateBook(wb As Workbook)
'Remove the links with the database table
'so that the different staff members' data will
'not be stored in the file.
Dim tblLink As Variant
Dim i As Long
tblLink = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(tblLink) Then
For i = 1 To UBound(tblLink)
wb.BreakLink Name:=TtlLink(i), Type:=xlExcelLinks
Next i
End If
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.