Sub Hide_Prot()
'
' Macro1 Macro
' Macro recorded 9/27/2005 by Paul Sasur
'
'
Dim mb As VbMsgBoxResult
Dim xcol As Integer
On Error GoTo BuildRange
xdata = Range("Hide_Protect")
row_tot = UBound(xdata, 1)
cnt_1 = 0
cnt_2 = 0
For cnt = 1 To row_tot
If xdata(cnt, 2) <> "" Then
cnt_2 = cnt_2 + 1
If Worksheets(xdata(cnt, 1)).Visible = False Then
cnt_1 = cnt_1 + 1
End If
End If
If xdata(cnt, 3) <> "" Then
cnt_2 = cnt_2 + 1
If Worksheets(xdata(cnt, 1)).ProtectContents = True Then
cnt_1 = cnt_1 + 1
End If
End If
Next cnt
xratio = cnt_1 / cnt_2
If ActiveWorkbook.ProtectStructure Then
flag = True
ActiveWorkbook.Unprotect password:="Quay"
Else
flag = False
End If
If xratio >= 0.5 Then
For cnt = 1 To row_tot
If xdata(cnt, 2) <> "" Then
Worksheets(xdata(cnt, 1)).Visible = True
End If
If xdata(cnt, 3) <> "" Then
Worksheets(xdata(cnt, 1)).Unprotect
End If
Next cnt
' Application.DisplayFormulaBar = True
' Application.EditDirectlyInCell = True
Else
For cnt = 1 To row_tot
If xdata(cnt, 2) <> "" Then
Worksheets(xdata(cnt, 1)).Visible = False
End If
If xdata(cnt, 3) <> "" Then
Worksheets(xdata(cnt, 1)).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
Next cnt
' Application.DisplayFormulaBar = False
' Application.EditDirectlyInCell = False
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
End If
If flag = True Then
ActiveWorkbook.Protect password:="Quay", Structure:=True, Windows:=False
End If
Exit Sub
BuildRange:
xtot = Worksheets.Count
If ActiveWorkbook.Path = "" Then
mb = MsgBox("You must save this workbook first.", , "Could Not Find Path")
End
End If
mb = MsgBox("This workbook does NOT contain a Range called Hide_Protect." & vbCrLf & "Do you want to build it now?", vbOKCancel, "Range Not Found")
If mb = vbCancel Then
Exit Sub
End If
xrow = ActiveCell.Row
xcol = ActiveCell.Column
xtot = Worksheets.Count
xcol1 = alpha(xcol)
xcol2 = alpha(xcol + 1)
xcol3 = alpha(xcol + 2)
mb = MsgBox("I am about to clear the contents of range " & xcol1 & xrow & ":" & xcol3 & xrow + xtot & "." & vbCrLf & "Is it okay to proceed?", vbOKCancel, "OK to DELETE?")
If mb = vbCancel Then
Exit Sub
End If
Range(xcol1 & xrow & ":" & xcol3 & xrow + xtot).Clear
Range(xcol1 & xrow).Value = "Sheets in Book"
Range(xcol2 & xrow).Value = "Sheets to Hide"
Range(xcol3 & xrow).Value = "Sheets to Lock"
Range(xcol1 & xrow + 1).Select
Call Sheet_Names("Column")
Range(xcol1 & xrow & ":" & xcol3 & xrow).Font.Bold = True
Range(xcol1 & xrow & ":" & xcol1 & xrow + xtot).Font.Bold = True
Range(xcol1 & xrow & ":" & xcol3 & xrow + xtot).Columns.AutoFit
For cnt = xrow + 1 To xrow + xtot
UserForm1.CheckBox1.Value = False
UserForm1.CheckBox2.Value = False
UserForm1.Frame1.Caption = Range(xcol1 & cnt).Value
UserForm1.Show
If UserForm1.CheckBox1.Value Then
Range(xcol2 & cnt).Value = "Yes"
End If
If UserForm1.CheckBox2.Value Then
Range(xcol3 & cnt).Value = "Yes"
End If
Next cnt
If InStr(1, ActiveSheet.Name, " ") = 0 Then
addy = "=" & ActiveSheet.Name & "!$" & xcol1 & "$" & xrow + 1 & ":$" & xcol3 & "$" & xrow + xtot
Else
addy = "='" & ActiveSheet.Name & "'!$" & xcol1 & "$" & xrow + 1 & ":$" & xcol3 & "$" & xrow + xtot
End If
ActiveWorkbook.Names.Add Name:="Hide_Protect", RefersTo:=addy
Resume
End Sub