本文于2023年9月10日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
内容提要
- 工作表权限控制代码解析
VBA代码
1、在用户窗体Usf_Login里：
Dim arrUser()
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim lastRow As Integer
Set ws = ThisWorkbook.Sheets("用户权限表")
With ws
lastRow = .UsedRange.Rows.Count
arrUser = .Range("A2:D" & lastRow).Value
End With
End Sub
Private Sub CmdLogin_Click()
Dim ws As Worksheet
Dim x As Integer
Application.ScreenUpdating = False
If Me.TxbUserID = "" Then
MsgBox "请输入用户ID！"
Exit Sub
End If
If Me.TxbPassWord = "" Then
MsgBox "请输入密码！"
Exit Sub
End If
For i = 1 To UBound(arrUser)
If arrUser(i, 1) = Me.TxbUserID Then
x = 1
If CStr(arrUser(i, 3)) = CStr(Me.TxbPassWord) Then
currUser = arrUser(i, 1)
currPermission = arrUser(i, 4)
Call BackTo
For Each ws In ThisWorkbook.Sheets
If currPermission = "All" Then
ws.Visible = xlSheetVisible
Else
If InStr(currPermission, "/" & ws.Name & "/") Then
ws.Visible = xlSheetVisible
End If
End If
Next
Set ws = Sheets("Main")
ws.Range("A1").Value = "当前用户：" & currUser & "(" & arrUser(i, 2) & ") " & Chr(10) & "用户权限：" & currPermission
If currPermission = "All" Or InStr(currPermission, "/用户权限表/") Then
ws.OLEObjects("CmdUserManage").Visible=True
ws.OLEObjects("CmdUserSheet").Visible = True
End If
Unload Me
Exit For
Else
MsgBox "密码不正确，请重新输入！"
With Me.TxbPassWord
.SetFocus
.SelStart = 0 ' 将光标位置设置为文本框的开头
.SelLength = Len(.Text) ' 选择整个文本框的文本
End With
Exit For
End If
End If
Next
If x = 0 Then
MsgBox "无此用户ID，请重新输入!"
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
Private Sub CmdExit_Click()
Call BackTo
Unload Me
EndSub
代码解析：
（1）Line1，定义模块级数组arrUser，用来存放用户权限表信息。
（2）line2~10，用户窗体初始化过程，把“用户权限表”存入数组arrUser。
（3）line12~64，登录按钮点击事件。
（A）line16~23，检查用户ID与密码是否输入，不能为空。
（B）line24~41，把用户输入的信息与数组中的信息进行比对，如果相符，则显示“权限”中的工作表。把当前登录用户的权限信息写入工作表“Main”的A1单元格。
（C）line42~45，如果如果权限为“All”或者有“用户权限表”的，工作表“Main”中的两个关于“用户权限”的按钮可见。
（D）line49~55，如果密码不符，则给出提示信息，退出过程，把控件焦点设为TxbPassWord，并选中内容，便于重新输入。
（E）line59~62，如果用户ID未正确输入，则给出提示信息，退出过程。
（4）line66~69，退出按钮点击事件。用户不输入用户名密码，点退出隐藏窗体进入工作表，为防止显示权限以外的表，这里干脆把除了“Main“以外的表全部隐藏。
2、在用户窗体Usf_Permission里：
Dim arrUser()
PrivateSubUserForm_Initialize()
Dim arrSheets()
Dim topPos As Integer
Dim ws As Worksheet
Dim iWidth As Integer
Dim lastRow As Integer
Set ws = ThisWorkbook.Sheets("用户权限表")
With ws
lastRow = .UsedRange.Rows.Count
arrUser = .Range("A2:D" & lastRow).Value
End With
For i = 1 To UBound(arrUser)
If arrUser(i, 1) <> "" And arrUser(i, 1) <> "admin" Then
Me.Cmbuser.AddItem arrUser(i, 1)
End If
Next
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Main" Then
ReDim Preserve arrSheets(k)
arrSheets(k) = ws.Name
k = k 1
End If
Next
leftPos = Me.Lbpermission.Left 10 ' 复选框的左侧位置
topPos = Me.Lbpermission.Top Me.Lbpermission.Height 10 ' 复选框的顶部位置
iWidth = 60
For i = LBound(arrSheets) To UBound(arrSheets)
'在指定位置插入复选框
Me.Controls.Add "Forms.CheckBox.1", "CheckBox" & i
'设置复选框的位置和属性
With Me.Controls("CheckBox" & i)
.Left = leftPos
.Top = topPos
.Width = iWidth
.Height = 20
.Caption = arrSheets(i)
.Value = False
End With
'更新位置
If (i 1) Mod 6 = 0 Then
'换行
leftPos = Me.Lbpermission.Left 10
topPos = topPos 20
Else
'同行下一个位置
leftPos = leftPos iWidth
End If
Next
End Sub
Private Sub Cmbuser_Change()
Dim ctrl As Control
For i = 1 To UBound(arrUser)
If arrUser(i, 1) = Me.Cmbuser Then
Me.LbUser = arrUser(i, 2)
For Each ctrl In Controls
If ctrl.Name Like "CheckBox*" Then
ctrl.Value = False
ctrl.ForeColor = vbBlack
If InStr(arrUser(i, 4), "/" & ctrl.Caption & "/") Then
ctrl.Value = True
ctrl.ForeColor = vbRed
End If
End If
Next
EndIf
Next
End Sub
Private Sub CmdSave_Click()
Dim ws As Worksheet
Dim newPermission As String
Dim ctrl As Control
Dim userCell As Range
Set ws = ThisWorkbook.Sheets("用户权限表")
ForEachctrlInControls
If ctrl.Name Like "CheckBox*" Then
If ctrl.Value = True Then
newPermission = newPermission & "/" & ctrl.Caption
End If
End If
Next
newPermission = newPermission & "/"
Set userCell = ws.Range("A:A").Find(Me.Cmbuser, LookIn:=xlValues)
If Not userCell Is Nothing Then
userCell.Offset(0, 3) = newPermission
Else
MsgBox "无此用户！"
End If
Unload Me
Usf_Permission.Show
End Sub
Private Sub CmdCheck_Click()
If Not wContinue("即将清除无效的工作表权限！") Then Exit Sub
Dim oldPermission As String
Dim newPermission As String
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
For i = 1 To UBound(arrUser)
oldPermission = arrUser(i, 4)
If oldPermission <> "All" Then
For Each ws In wb.Sheets
If InStr(oldPermission, "/" & ws.Name & "/") Then
newPermission = newPermission & "/" & ws.Name
End If
Next
If newPermission <> "" Then
newPermission = newPermission & "/"
End If
arrUser(i, 4) = newPermission
newPermission = ""
End If
Next
Set ws = wb.Sheets("用户权限表")
ws.Range("A2").Resize(UBound(arrUser), 4) = arrUser
MsgBox "权限整理完毕！"
Unload Me
Usf_Permission.Show
End Sub
Private Sub CmeExit_Click()
Unload Me
EndSub
代码解析：
（1）Line1，定义模块级数组arrUser，用来存放用户权限表信息。
（2）line2~50，用户窗体初始化过程，把“用户权限表”存入数组arrUser，把工作表名称作为CheckBox控件的Caption列出来。
（A）line13~17，把用户ID添加到组合框的list。
（B）line18~24，把除“Main”以外的工作表名装入数组。
（C）line25~49，把工作表名作为CheckBox的Caption，添加到用户窗体，供勾选，动态添加控件的代码直接复制【Excel VBA 学生成绩排名（更新）/SQL循环查询/嵌套查询】，稍作修改。
（3）line52~69，Cmbuser_Change事件，根据当前用户的权限信息，把对应CheckBox勾选并改为红色。
（4）line71~93，保存按钮点击事件。把勾选的工作表名写入用户权限表。
（5）line95~122，整理按钮点击事件。如果在设置好用户权限后，工作表有改名或删除的，那么用户权限就可能有不存在的表。把这些不存在的工作表权限删除。
（6）line124~126，退出按钮点击事件，退出过程。
3、在myModule里，两个自定义函数：
Public currUser As String
Public currPermission As String
Sub BackTo()
Dim ws As Worksheet
Dim curSht As String
On Error Resume Next
Sheets("Main").Activate
ActiveSheet.Visible = xlSheetVisible '显示工作表
curSht = ActiveSheet.Name
'遍历所有工作表，隐藏不需要显示的工作表
For Each ws In Excel.ThisWorkbook.Worksheets
If ws.Name <> curSht Then
'设置工作表对象的Visible属性
'ws.Visible = xlSheetHidden
ws.Visible = xlSheetVeryHidden
End If
Next
End Sub
Function wContinue(Msg) As Boolean
'确认继续函数
Dim Config As Long
Config = vbYesNo vbDefaultButton2 vbQuestion
Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) _
& "否(N)返回！", Config, "请确认操作！")
wContinue = Ans = vbYes
EndFunction
代码解析：
（1）Line1~2，定义两个公共变量。
（2）line4~19，回到主页，返回到工作表“Main”，隐藏其他工作表。
（3）line21~28，确认继续执行函数。
4、在工作表“Main”里：
Private Sub CmdLogin_Click()
Me.CmdUserManage.Visible = False
Me.CmdUserSheet.Visible = False
Me.Range("A1") = ""
Usf_Login.Show
End Sub
Private Sub CmdUserManage_Click()
Usf_Permission.Show
End Sub
Private Sub CmdUserSheet_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("用户权限表")
With ws
.Visible = xlSheetVisible
.Activate
End With
End Sub
Private Sub Worksheet_Deactivate()
If currUser = "" Then
Me.CmdUserManage.Visible = False
Me.CmdUserSheet.Visible = False
Me.Range("A1") = ""
Call BackTo
Usf_Login.Show
End If
End Sub
代码解析：
（1）Line1~6，用户登录按钮点击事件，把其他两个命令按钮隐藏，A1单元格清空，然后再显示用户登录窗体Usf_Login。
（2）line8~10，用户权限管理按钮点击事件，显示用户权限管理窗体Usf_Permission。
（3）line12~19，用户权限表按钮点击事件，显示“用户权限表”。
（4）line21~29，工作表Deactivate事件，工作表转为非激活，等同于点击其他工作表。这里如果系发生统异常，用户权限信息被清空，则返回到工作表“Main”，隐藏其他工作表，显示用户登录窗体，必须重新登录后才能使用，以防止进入权限以外的工作表。
5、在ThisWorkBook里：
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim ws As Worksheet
Dim sp As Shape
Call BackTo
Set ws = Sheets("Main")
ws.OLEObjects("CmdUserManage").Visible = False
ws.OLEObjects("CmdUserSheet").Visible = False
ws.Range("A1") = ""
ThisWorkbook.Save
End Sub
Private Sub Workbook_Open()
Usf_Login.Show
EndSub
代码解析：
（1）Line1~10，工作簿BeforeClose关闭前事件，调用BackTo过程，把工作表“Main”上的其他两个按钮隐藏，A1单元格清空。
（2）line12~14，工作簿Open打开事件，显示用户登录窗体Usf_Login。。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留个言、分享一下呗！感谢！
