Skip to content

Instantly share code, notes, and snippets.

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.
'Delete the unnecessary worksheet.
'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
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.