Hi!
I have an excel workbook at work. I didn't create it but the person who did his no longer with the organization and now I'm the owner of that workbook and I'm completely lost with vba codes.
There are many modules, forms, worksheets which makes it even more complicated to me. I'm running into severals error code. I'll try to be as clear as possible with the errors.
Error 1. Compile Error - Sub or Function not defined
Then I click 'ok' and the code appears
- Sub Add_topic is highlighted in yellow
- Call unprotect_Dup_Topic(PW) is highlighted in blue (please scroll below to see in code)
Can anyone help me with that matter.
Sub Add_Topic()
Application.ScreenUpdating = False
Application.DisplayAlerts = True
'
Dim LastSheet As Integer
Dim NewSheet As Integer
Dim mysheet As String
Dim myTopic As String
Dim mySubject As String
Dim dmySubject As String
Dim myLength As Integer
Dim myDash As Integer
Dim myTopicNo As Integer
Dim var1 As String
Dim var2 As String
Dim var3 As Integer
Dim myStyle As Integer
Dim myTitle As String
'
LastSheet = Worksheets.Count - 1
NewSheet = LastSheet - 6
myStyle = Range("Cklst_Style").Value
var1 = Range("dmyTopic").Value
var2 = " Title"
If myStyle = 4 Then var2 = " Name & ID"
var3 = 7
If myStyle = 4 Then var3 = 9
'
myTopicNo = NewSheet
If Range("Cklst_Style").Value = 2 Then myTopicNo = NewSheet - 1
'
If myStyle = 4 _
Then
response = vbNo
Else
response = MsgBox("Do you want to duplicate an existing Topic?" _
, vbYesNoCancel, "Audit Checklist")
End If
If response = vbCancel Then GoTo Done
'
ActiveWorkbook.Unprotect Password:="dAcv72Br"
'
If response = vbNo _
Then
If myStyle = 4 _
Then
Sheets(7).Select
Sheets(7).Copy Before:=Sheets("Template")
Sheets(LastSheet).Select
Sheets(LastSheet).Name = UCase(var1) & " " & myTopicNo
ActiveSheet.Unprotect Password:="dAcv72Br"
Sheets(7).Range("Print_Area").Copy
Sheets(LastSheet).Range("Print_Area").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Else
Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets("Template")
Sheets("Template").Visible = False
Sheets(LastSheet).Select
Sheets(LastSheet).Name = UCase(var1) & " " & myTopicNo
ActiveSheet.Unprotect Password:="dAcv72Br"
Sheets("Template").Range("Print_Area").Copy
Sheets(LastSheet).Range("Print_Area").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
End If
Else
try_again:
If Range("Num_Selected") = 0 _
Then
MsgBox "There are no Topics selected from which to duplicate." _
& vbCr & vbCr _
& "Please select a Topic and try again." _
, vbExclamation, "Audit Checklist"
GoTo Done
Else
End If
mysheet = InputBox("Type the number of the Topic you wish to duplicate" _
& vbCr & vbCr _
& "NOTE: You may not duplicate an unselected topic.", _
"Audit Checklist")
If mysheet = "" Then GoTo Done
If myStyle = 2 Then mysheet = mysheet + 1
If mysheet < 1 _
Or mysheet > NewSheet - 1 _
Then
MsgBox "You did not type a valid Topic number." & _
(Chr(13)) & (Chr(13)) & _
"Please try again", vbExclamation, "Audit Checklist"
GoTo try_again
Else
End If
If Worksheets(mysheet + 6).Visible = False _
Then
MsgBox "You can not duplicate an unselected Topic." & _
(Chr(13)) & (Chr(13)) & _
"Please try again", vbExclamation, "Audit Checklist"
GoTo try_again
Else
End If
Sheets("Template").Visible = True
Sheets(mysheet + 6).Copy Before:=Sheets("Template")
Sheets("Template").Visible = False
Sheets(LastSheet).Select
Sheets(LastSheet).Name = "Topic " & myTopicNo
ActiveSheet.Unprotect Password:="dAcv72Br"
Sheets(mysheet + 6).Range("Print_Area").Copy
Sheets(LastSheet).Range("Print_Area").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
End If
'
ActiveSheet.Unprotect Password:="dAcv72Br"
Range("TOPIC_Title").Select
If response = vbNo _
Then
dmySubject = UCase(var1) & UCase(var2)
Try_again2:
mySubject = InputBox("Type the" & var2 & " of the " & var1 & ".", _
"Audit Checklist", dmySubject)
If mySubject = "" Then GoTo Try_again2
mySubject = UCase(mySubject)
ActiveCell.FormulaR1C1 = UCase(var1) & " " & myTopicNo & " -- " & mySubject
Else
myTopic = ActiveCell.Value
myDash = WorksheetFunction.Find("--", myTopic)
myLength = Len(myTopic)
mySubject = Right(myTopic, myLength - myDash - 2)
If mySubject = "(INSERT TOPIC TITLE BY CLICKING ON THE EDIT BUTTON)" _
Then
MsgBox "Before you can duplicate this Topic, you must first give it " _
& "a valid Topic Title." & Chr(13) & Chr(13) _
& "Click the Edit Button on the Topic Sheet to Edit the Title.", _
vbExclamation, "Audit Checklist"
Application.DisplayAlerts = False
Sheets(LastSheet).Delete
Application.DisplayAlerts = True
Sheets(mysheet + 6).Select
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
Exit Sub
Else
End If
'
If Right(mySubject, 11) <> "(continued)" _
Then
mySubject = UCase(mySubject) & " (continued)"
Else
End If
myTopic = "TOPIC " & myTopicNo & " -- " & mySubject
Get_Topic_Title:
temp = InputBox("The following is the suggested Topic title." _
& vbCr & vbCr _
& "You may accept or edit this title, as appropriate." _
, "Audit Checklist", mySubject)
If temp = "" _
Then
MsgBox "The topic sheet has already been added." _
& vbCr & vbCr _
& "At this point you must assign a topic title." _
& vbCr & vbCr _
& "Please try again, and next time, do not click the Cancel button." _
, vbExclamation + vbOKOnly, _
"Audit Checklist"
GoTo Get_Topic_Title
Else
myTopic = "TOPIC " & myTopicNo & " -- " & UCase(temp)
End If
If Right(myTopic, 11) = "(CONTINUED)" _
Then
myLength = Len(myTopic)
myTopic = Left(myTopic, myLength - 11) & "(continued)"
Else
End If
ActiveCell.FormulaR1C1 = myTopic
Range("A3").FormulaR1C1 = "s"
End If
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(0, -1).Select
Selection.EntireRow.Insert
myrow = Selection.Row
Range("Format_TOPIC").Copy
ActiveSheet.Paste
Range("D8").Select
Selection.Offset(NewSheet - 1, -2).Formula = _
"=IF('" & var1 & " " & myTopicNo & "'!Results=2,"" Needs Improvement"",IF(AND('" & var1 _
& " " & myTopicNo & "'!Assessed=0,S" & myrow _
& "=TRUE),"" Not Yet Assessed"",""""))"
Selection.Offset(NewSheet - 1, 1).Formula = _
"=MID('" & var1 & " " & myTopicNo & "'!C$3," & var3 & ",100)"
ActiveSheet.Hyperlinks.Add anchor:=Selection.Offset(NewSheet - 1, 1), Address:="", _
SubAddress:="'" & var1 & " " & myTopicNo & "'!C3"
Selection.Offset(NewSheet - 1, 9).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_ST"
Selection.Offset(NewSheet - 1, 10).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_OBS"
Selection.Offset(NewSheet - 1, 11).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_PA"
Selection.Offset(NewSheet - 1, 12).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_CA"
Selection.Offset(NewSheet - 1, 13).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfFindings-'" _
& var1 & " " & myTopicNo & "'!NumOfCategories"
Selection.Offset(NewSheet - 1, 14).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfPA_CA_Assigned-'" _
& var1 & " " & myTopicNo & "'!NumOfCC_Assigned"
Selection.Offset(NewSheet - 1, 16).Formula = _
"='" & var1 & " " & myTopicNo & "'!CC08_NoProcedure"
Selection.Offset(NewSheet - 1, 17).Formula = _
"='" & var1 & " " & myTopicNo & "'!X99_NoOther"
'
Range("C6").Select
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
'
Call Set_NewTab_Name(NewSheet)
'
Application.ScreenUpdating = True
If response = vbYes _
Then
Application.ScreenUpdating = False
PW = "OK"
Call unprotect_Dup_Topic(PW)
Sheets(mysheet + 6).Select
myTitle = MsgBox("Would you like to be able to edit the title of the " _
& "original Topic you are duplicating?" _
& vbCr & vbCr _
& "This is useful when the duplicated sheets are for auditing " _
& "multiple subjects. You can then append each title with the " _
& "subject's name or other identification.", vbInformation + vbYesNo, _
"Audit Checklist")
If myTitle = vbNo Then GoTo Skip_Title
ActiveSheet.Unprotect Password:="dAcv72Br"
ActiveSheet.Shapes("Edit_Button").Visible = True
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Range("TOPIC_Title").Select
Skip_Title:
'
'reset intro links
'
Sheets(LastSheet).Select
Range("Intro_Rows").Select
NumOfRows = Range("Intro_Rows").Value * 1
ActiveSheet.Unprotect Password:="dAcv72Br"
For Y = 1 To NumOfRows
Range("Intro").Offset(Y - 1, 0).Select
mylinkrow = Selection.Row
mysubaddress = Cells(mylinkrow, Range("Link_Ref").Column).Formula
mysubaddress = Mid(mysubaddress, 2, 100)
If mysubaddress <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", _
SubAddress:="'" & ActiveSheet.Name & "'!" & mysubaddress
End If
Next Y
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Range("TOPIC_Title").Select
'
Else
End If
'
Done:
'
Sheets("Summary").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'
End Sub
Sub Add_XX_Topics()
'
Call Password_Macro(pass)
'
' Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Dim LastSheet As Integer
Dim NewSheet As Integer
Dim mysheet As String
Dim myTopic As String
Dim mySubject As String
Dim myLength As Integer
Dim myDash As Integer
'
response = InputBox("How many sheets do you want to add?", "Audit Checklist")
If response < 1 Then Exit Sub
For z = 1 To response
LastSheet = Worksheets.Count - 1
NewSheet = LastSheet - 6
'
'
ActiveWorkbook.Unprotect Password:="dAcv72Br"
'
Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets("Template")
Sheets("Template").Visible = False
Sheets(LastSheet).Select
Sheets(LastSheet).Name = "Topic " & NewSheet
'
ActiveSheet.Unprotect Password:="dAcv72Br"
Range("TOPIC_Title").Select
mySubject = "Topic Title"
mySubject = UCase(mySubject)
ActiveCell.FormulaR1C1 = "TOPIC " & NewSheet & " -- " & mySubject
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(0, -1).Select
Selection.EntireRow.Insert
myrow = Selection.Row
Range("Format_TOPIC").Copy
ActiveSheet.Paste
Range("D8").Select
Selection.Offset(NewSheet - 1, -2).Formula = _
"=IF('Topic " & NewSheet & "'!$W$4=2,"" Needs Improvement"",IF(AND('Topic " & NewSheet _
& "'!$AD$4=0,S" & myrow & "=TRUE),"" Not Yet Assessed"",""""))"
Selection.Offset(NewSheet - 1, 1).Formula = _
"=MID('Topic " & NewSheet & "'!C$3,7,100)"
ActiveSheet.Hyperlinks.Add anchor:=Selection.Offset(NewSheet - 1, 1), Address:="", _
SubAddress:="'Topic " & NewSheet & "'!C3"
'
Selection.Offset(NewSheet - 1, 9).Formula = _
"='" & var1 & " " & myTopicNo & "'!AC$3"
Selection.Offset(NewSheet - 1, 10).Formula = _
"='" & var1 & " " & myTopicNo & "'!AD$3"
Selection.Offset(NewSheet - 1, 11).Formula = _
"='" & var1 & " " & myTopicNo & "'!AE$3"
Selection.Offset(NewSheet - 1, 12).Formula = _
"='" & var1 & " " & myTopicNo & "'!AF$3"
Selection.Offset(NewSheet - 1, 13).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfFindings-'" _
& var1 & " " & myTopicNo & "'!NumOfCategories"
Selection.Offset(NewSheet - 1, 14).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfPA_CA_Assigned-'" _
& var1 & " " & myTopicNo & "'!NumOfCC_Assigned"
Selection.Offset(NewSheet - 1, 16).Formula = _
"='" & var1 & " " & myTopicNo & "'!CC08_NoProcedure"
'
Range("C6").Select
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
'
Call Set_NewTab_Name(NewSheet)
'
Next z
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'
End Sub
Sub Remove_Topic()
'
Dim LastSheet As Integer
'
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="dAcv72Br"
LastSheet = Worksheets.Count - 2
'
myStyle = Range("Cklst_Style").Value
var1 = Range("dmyTopic").Value
var2 = " Title"
If myStyle = 4 Then var2 = " Name & ID"
'
For X = LastSheet To 8 Step -1
'
Worksheets(X).Activate
Range("C3").Select
'
If Selection.Offset(0, -2) = "s" _
Then
'
response = MsgBox("This will delete the last user-defined " & var1 & _
" and all its contents." & _
(Chr(13)) & (Chr(13)) & _
"Are you sure you want to continue?", vbExclamation + vbYesNo, _
"Audit Checklist")
If response <> vbYes Then GoTo Done
'
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(-1, 0).EntireRow.Delete
'
Range("C6").Select
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
GoTo Done
Else
If Selection.Offset(0, -2) = "L" _
Or Selection.Offset(X, -2) = "l" _
Or Selection.Offset(X, -2) = "d" _
Then
MsgBox "You may not remove any more " & var1 & "s." & _
(Chr(13)) & (Chr(13)) & _
"Only user-defined " & var1 & "s can be removed.", vbCritical, _
"Audit Checklist"
GoTo Done
Else
End If
End If
'
Next X
'
If X < 8 Then MsgBox "You may not remove any more " & var1 & "s.", vbCritical, _
"Audit Checklist"
'
Done:
'
Worksheets("Summary").Select
Range("C6").Select
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
Application.ScreenUpdating = True
'
End Sub
Sub Remove_XX_Topics()
'
Call Password_Macro(pass)
'
Dim LastSheet As Integer
'
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="dAcv72Br"
response = InputBox("How many sheets do you want to remove?", "Audit Checklist", 49)
If response < 1 Or response > 49 Then Exit Sub
For z = 1 To response
LastSheet = Worksheets.Count - 2
'
For X = LastSheet To 8 Step -1
'
Worksheets(X).Activate
Range("C3").Select
'
If Selection.Offset(0, -2) = "s" _
Then
'
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(-1, 0).EntireRow.Delete
'
Range("C6").Select
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
GoTo Done
Else
If Selection.Offset(0, -2) = "L" Or Selection.Offset(X, -2) = "l" _
Then
MsgBox "You may not remove any more Topics." & _
(Chr(13)) & (Chr(13)) & _
"Only user-defined Topics can be removed.", vbCritical, _
"Audit Checklist"
GoTo Done
Else
End If
End If
'
Next X
'
If X < 8 Then MsgBox "You may not remove any more Topics.", vbCritical, _
"Audit Checklist"
'
Done:
'
Next z
Worksheets("Summary").Select
Range("C6").Select
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
Application.ScreenUpdating = True
'
End Sub
I have an excel workbook at work. I didn't create it but the person who did his no longer with the organization and now I'm the owner of that workbook and I'm completely lost with vba codes.
There are many modules, forms, worksheets which makes it even more complicated to me. I'm running into severals error code. I'll try to be as clear as possible with the errors.
Error 1. Compile Error - Sub or Function not defined
Then I click 'ok' and the code appears
- Sub Add_topic is highlighted in yellow
- Call unprotect_Dup_Topic(PW) is highlighted in blue (please scroll below to see in code)
Can anyone help me with that matter.
Sub Add_Topic()
Application.ScreenUpdating = False
Application.DisplayAlerts = True
'
Dim LastSheet As Integer
Dim NewSheet As Integer
Dim mysheet As String
Dim myTopic As String
Dim mySubject As String
Dim dmySubject As String
Dim myLength As Integer
Dim myDash As Integer
Dim myTopicNo As Integer
Dim var1 As String
Dim var2 As String
Dim var3 As Integer
Dim myStyle As Integer
Dim myTitle As String
'
LastSheet = Worksheets.Count - 1
NewSheet = LastSheet - 6
myStyle = Range("Cklst_Style").Value
var1 = Range("dmyTopic").Value
var2 = " Title"
If myStyle = 4 Then var2 = " Name & ID"
var3 = 7
If myStyle = 4 Then var3 = 9
'
myTopicNo = NewSheet
If Range("Cklst_Style").Value = 2 Then myTopicNo = NewSheet - 1
'
If myStyle = 4 _
Then
response = vbNo
Else
response = MsgBox("Do you want to duplicate an existing Topic?" _
, vbYesNoCancel, "Audit Checklist")
End If
If response = vbCancel Then GoTo Done
'
ActiveWorkbook.Unprotect Password:="dAcv72Br"
'
If response = vbNo _
Then
If myStyle = 4 _
Then
Sheets(7).Select
Sheets(7).Copy Before:=Sheets("Template")
Sheets(LastSheet).Select
Sheets(LastSheet).Name = UCase(var1) & " " & myTopicNo
ActiveSheet.Unprotect Password:="dAcv72Br"
Sheets(7).Range("Print_Area").Copy
Sheets(LastSheet).Range("Print_Area").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Else
Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets("Template")
Sheets("Template").Visible = False
Sheets(LastSheet).Select
Sheets(LastSheet).Name = UCase(var1) & " " & myTopicNo
ActiveSheet.Unprotect Password:="dAcv72Br"
Sheets("Template").Range("Print_Area").Copy
Sheets(LastSheet).Range("Print_Area").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
End If
Else
try_again:
If Range("Num_Selected") = 0 _
Then
MsgBox "There are no Topics selected from which to duplicate." _
& vbCr & vbCr _
& "Please select a Topic and try again." _
, vbExclamation, "Audit Checklist"
GoTo Done
Else
End If
mysheet = InputBox("Type the number of the Topic you wish to duplicate" _
& vbCr & vbCr _
& "NOTE: You may not duplicate an unselected topic.", _
"Audit Checklist")
If mysheet = "" Then GoTo Done
If myStyle = 2 Then mysheet = mysheet + 1
If mysheet < 1 _
Or mysheet > NewSheet - 1 _
Then
MsgBox "You did not type a valid Topic number." & _
(Chr(13)) & (Chr(13)) & _
"Please try again", vbExclamation, "Audit Checklist"
GoTo try_again
Else
End If
If Worksheets(mysheet + 6).Visible = False _
Then
MsgBox "You can not duplicate an unselected Topic." & _
(Chr(13)) & (Chr(13)) & _
"Please try again", vbExclamation, "Audit Checklist"
GoTo try_again
Else
End If
Sheets("Template").Visible = True
Sheets(mysheet + 6).Copy Before:=Sheets("Template")
Sheets("Template").Visible = False
Sheets(LastSheet).Select
Sheets(LastSheet).Name = "Topic " & myTopicNo
ActiveSheet.Unprotect Password:="dAcv72Br"
Sheets(mysheet + 6).Range("Print_Area").Copy
Sheets(LastSheet).Range("Print_Area").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
End If
'
ActiveSheet.Unprotect Password:="dAcv72Br"
Range("TOPIC_Title").Select
If response = vbNo _
Then
dmySubject = UCase(var1) & UCase(var2)
Try_again2:
mySubject = InputBox("Type the" & var2 & " of the " & var1 & ".", _
"Audit Checklist", dmySubject)
If mySubject = "" Then GoTo Try_again2
mySubject = UCase(mySubject)
ActiveCell.FormulaR1C1 = UCase(var1) & " " & myTopicNo & " -- " & mySubject
Else
myTopic = ActiveCell.Value
myDash = WorksheetFunction.Find("--", myTopic)
myLength = Len(myTopic)
mySubject = Right(myTopic, myLength - myDash - 2)
If mySubject = "(INSERT TOPIC TITLE BY CLICKING ON THE EDIT BUTTON)" _
Then
MsgBox "Before you can duplicate this Topic, you must first give it " _
& "a valid Topic Title." & Chr(13) & Chr(13) _
& "Click the Edit Button on the Topic Sheet to Edit the Title.", _
vbExclamation, "Audit Checklist"
Application.DisplayAlerts = False
Sheets(LastSheet).Delete
Application.DisplayAlerts = True
Sheets(mysheet + 6).Select
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
Exit Sub
Else
End If
'
If Right(mySubject, 11) <> "(continued)" _
Then
mySubject = UCase(mySubject) & " (continued)"
Else
End If
myTopic = "TOPIC " & myTopicNo & " -- " & mySubject
Get_Topic_Title:
temp = InputBox("The following is the suggested Topic title." _
& vbCr & vbCr _
& "You may accept or edit this title, as appropriate." _
, "Audit Checklist", mySubject)
If temp = "" _
Then
MsgBox "The topic sheet has already been added." _
& vbCr & vbCr _
& "At this point you must assign a topic title." _
& vbCr & vbCr _
& "Please try again, and next time, do not click the Cancel button." _
, vbExclamation + vbOKOnly, _
"Audit Checklist"
GoTo Get_Topic_Title
Else
myTopic = "TOPIC " & myTopicNo & " -- " & UCase(temp)
End If
If Right(myTopic, 11) = "(CONTINUED)" _
Then
myLength = Len(myTopic)
myTopic = Left(myTopic, myLength - 11) & "(continued)"
Else
End If
ActiveCell.FormulaR1C1 = myTopic
Range("A3").FormulaR1C1 = "s"
End If
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(0, -1).Select
Selection.EntireRow.Insert
myrow = Selection.Row
Range("Format_TOPIC").Copy
ActiveSheet.Paste
Range("D8").Select
Selection.Offset(NewSheet - 1, -2).Formula = _
"=IF('" & var1 & " " & myTopicNo & "'!Results=2,"" Needs Improvement"",IF(AND('" & var1 _
& " " & myTopicNo & "'!Assessed=0,S" & myrow _
& "=TRUE),"" Not Yet Assessed"",""""))"
Selection.Offset(NewSheet - 1, 1).Formula = _
"=MID('" & var1 & " " & myTopicNo & "'!C$3," & var3 & ",100)"
ActiveSheet.Hyperlinks.Add anchor:=Selection.Offset(NewSheet - 1, 1), Address:="", _
SubAddress:="'" & var1 & " " & myTopicNo & "'!C3"
Selection.Offset(NewSheet - 1, 9).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_ST"
Selection.Offset(NewSheet - 1, 10).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_OBS"
Selection.Offset(NewSheet - 1, 11).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_PA"
Selection.Offset(NewSheet - 1, 12).Formula = _
"='" & var1 & " " & myTopicNo & "'!Count_CA"
Selection.Offset(NewSheet - 1, 13).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfFindings-'" _
& var1 & " " & myTopicNo & "'!NumOfCategories"
Selection.Offset(NewSheet - 1, 14).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfPA_CA_Assigned-'" _
& var1 & " " & myTopicNo & "'!NumOfCC_Assigned"
Selection.Offset(NewSheet - 1, 16).Formula = _
"='" & var1 & " " & myTopicNo & "'!CC08_NoProcedure"
Selection.Offset(NewSheet - 1, 17).Formula = _
"='" & var1 & " " & myTopicNo & "'!X99_NoOther"
'
Range("C6").Select
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
'
Call Set_NewTab_Name(NewSheet)
'
Application.ScreenUpdating = True
If response = vbYes _
Then
Application.ScreenUpdating = False
PW = "OK"
Call unprotect_Dup_Topic(PW)
Sheets(mysheet + 6).Select
myTitle = MsgBox("Would you like to be able to edit the title of the " _
& "original Topic you are duplicating?" _
& vbCr & vbCr _
& "This is useful when the duplicated sheets are for auditing " _
& "multiple subjects. You can then append each title with the " _
& "subject's name or other identification.", vbInformation + vbYesNo, _
"Audit Checklist")
If myTitle = vbNo Then GoTo Skip_Title
ActiveSheet.Unprotect Password:="dAcv72Br"
ActiveSheet.Shapes("Edit_Button").Visible = True
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Range("TOPIC_Title").Select
Skip_Title:
'
'reset intro links
'
Sheets(LastSheet).Select
Range("Intro_Rows").Select
NumOfRows = Range("Intro_Rows").Value * 1
ActiveSheet.Unprotect Password:="dAcv72Br"
For Y = 1 To NumOfRows
Range("Intro").Offset(Y - 1, 0).Select
mylinkrow = Selection.Row
mysubaddress = Cells(mylinkrow, Range("Link_Ref").Column).Formula
mysubaddress = Mid(mysubaddress, 2, 100)
If mysubaddress <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", _
SubAddress:="'" & ActiveSheet.Name & "'!" & mysubaddress
End If
Next Y
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Range("TOPIC_Title").Select
'
Else
End If
'
Done:
'
Sheets("Summary").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'
End Sub
Sub Add_XX_Topics()
'
Call Password_Macro(pass)
'
' Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Dim LastSheet As Integer
Dim NewSheet As Integer
Dim mysheet As String
Dim myTopic As String
Dim mySubject As String
Dim myLength As Integer
Dim myDash As Integer
'
response = InputBox("How many sheets do you want to add?", "Audit Checklist")
If response < 1 Then Exit Sub
For z = 1 To response
LastSheet = Worksheets.Count - 1
NewSheet = LastSheet - 6
'
'
ActiveWorkbook.Unprotect Password:="dAcv72Br"
'
Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets("Template")
Sheets("Template").Visible = False
Sheets(LastSheet).Select
Sheets(LastSheet).Name = "Topic " & NewSheet
'
ActiveSheet.Unprotect Password:="dAcv72Br"
Range("TOPIC_Title").Select
mySubject = "Topic Title"
mySubject = UCase(mySubject)
ActiveCell.FormulaR1C1 = "TOPIC " & NewSheet & " -- " & mySubject
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(0, -1).Select
Selection.EntireRow.Insert
myrow = Selection.Row
Range("Format_TOPIC").Copy
ActiveSheet.Paste
Range("D8").Select
Selection.Offset(NewSheet - 1, -2).Formula = _
"=IF('Topic " & NewSheet & "'!$W$4=2,"" Needs Improvement"",IF(AND('Topic " & NewSheet _
& "'!$AD$4=0,S" & myrow & "=TRUE),"" Not Yet Assessed"",""""))"
Selection.Offset(NewSheet - 1, 1).Formula = _
"=MID('Topic " & NewSheet & "'!C$3,7,100)"
ActiveSheet.Hyperlinks.Add anchor:=Selection.Offset(NewSheet - 1, 1), Address:="", _
SubAddress:="'Topic " & NewSheet & "'!C3"
'
Selection.Offset(NewSheet - 1, 9).Formula = _
"='" & var1 & " " & myTopicNo & "'!AC$3"
Selection.Offset(NewSheet - 1, 10).Formula = _
"='" & var1 & " " & myTopicNo & "'!AD$3"
Selection.Offset(NewSheet - 1, 11).Formula = _
"='" & var1 & " " & myTopicNo & "'!AE$3"
Selection.Offset(NewSheet - 1, 12).Formula = _
"='" & var1 & " " & myTopicNo & "'!AF$3"
Selection.Offset(NewSheet - 1, 13).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfFindings-'" _
& var1 & " " & myTopicNo & "'!NumOfCategories"
Selection.Offset(NewSheet - 1, 14).Formula = _
"='" & var1 & " " & myTopicNo & "'!NumOfPA_CA_Assigned-'" _
& var1 & " " & myTopicNo & "'!NumOfCC_Assigned"
Selection.Offset(NewSheet - 1, 16).Formula = _
"='" & var1 & " " & myTopicNo & "'!CC08_NoProcedure"
'
Range("C6").Select
'
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
'
Call Set_NewTab_Name(NewSheet)
'
Next z
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'
End Sub
Sub Remove_Topic()
'
Dim LastSheet As Integer
'
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="dAcv72Br"
LastSheet = Worksheets.Count - 2
'
myStyle = Range("Cklst_Style").Value
var1 = Range("dmyTopic").Value
var2 = " Title"
If myStyle = 4 Then var2 = " Name & ID"
'
For X = LastSheet To 8 Step -1
'
Worksheets(X).Activate
Range("C3").Select
'
If Selection.Offset(0, -2) = "s" _
Then
'
response = MsgBox("This will delete the last user-defined " & var1 & _
" and all its contents." & _
(Chr(13)) & (Chr(13)) & _
"Are you sure you want to continue?", vbExclamation + vbYesNo, _
"Audit Checklist")
If response <> vbYes Then GoTo Done
'
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(-1, 0).EntireRow.Delete
'
Range("C6").Select
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
GoTo Done
Else
If Selection.Offset(0, -2) = "L" _
Or Selection.Offset(X, -2) = "l" _
Or Selection.Offset(X, -2) = "d" _
Then
MsgBox "You may not remove any more " & var1 & "s." & _
(Chr(13)) & (Chr(13)) & _
"Only user-defined " & var1 & "s can be removed.", vbCritical, _
"Audit Checklist"
GoTo Done
Else
End If
End If
'
Next X
'
If X < 8 Then MsgBox "You may not remove any more " & var1 & "s.", vbCritical, _
"Audit Checklist"
'
Done:
'
Worksheets("Summary").Select
Range("C6").Select
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
Application.ScreenUpdating = True
'
End Sub
Sub Remove_XX_Topics()
'
Call Password_Macro(pass)
'
Dim LastSheet As Integer
'
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="dAcv72Br"
response = InputBox("How many sheets do you want to remove?", "Audit Checklist", 49)
If response < 1 Or response > 49 Then Exit Sub
For z = 1 To response
LastSheet = Worksheets.Count - 2
'
For X = LastSheet To 8 Step -1
'
Worksheets(X).Activate
Range("C3").Select
'
If Selection.Offset(0, -2) = "s" _
Then
'
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'
Sheets("Summary").Select
ActiveSheet.Unprotect Password:="dAcv72Br"
'
Range("End_of_Topics").Offset(-1, 0).EntireRow.Delete
'
Range("C6").Select
ActiveSheet.Protect Password:="dAcv72Br", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
'
GoTo Done
Else
If Selection.Offset(0, -2) = "L" Or Selection.Offset(X, -2) = "l" _
Then
MsgBox "You may not remove any more Topics." & _
(Chr(13)) & (Chr(13)) & _
"Only user-defined Topics can be removed.", vbCritical, _
"Audit Checklist"
GoTo Done
Else
End If
End If
'
Next X
'
If X < 8 Then MsgBox "You may not remove any more Topics.", vbCritical, _
"Audit Checklist"
'
Done:
'
Next z
Worksheets("Summary").Select
Range("C6").Select
ActiveWorkbook.Protect Password:="dAcv72Br", Structure:=True
Application.ScreenUpdating = True
'
End Sub
