本文于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 WithEnd SubPrivate 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 = TrueEnd SubPrivate Sub CmdExit_Click() Call BackTo Unload MeEnd Sub
代码解析：
（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()Private Sub UserForm_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 NextEnd SubPrivate 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 End If NextEnd SubPrivate Sub CmdSave_Click() Dim ws As Worksheet Dim newPermission As String Dim ctrl As Control Dim userCell As Range Set ws = ThisWorkbook.Sheets("用户权限表") For Each ctrl In Controls 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.ShowEnd SubPrivate 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.ShowEnd SubPrivate Sub CmeExit_Click() Unload MeEnd Sub
代码解析：
（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 StringPublic currPermission As StringSub 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 NextEnd SubFunction wContinue(Msg) As Boolean '确认继续函数 Dim Config As Long Config = vbYesNo + vbDefaultButton2 + vbQuestion Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) _ & "否(N)返回！", Config, "请确认操作！") wContinue = Ans = vbYesEnd Function
代码解析：
（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.ShowEnd SubPrivate Sub CmdUserManage_Click() Usf_Permission.ShowEnd SubPrivate Sub CmdUserSheet_Click() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("用户权限表") With ws .Visible = xlSheetVisible .Activate End WithEnd SubPrivate Sub Worksheet_Deactivate() If currUser = "" Then Me.CmdUserManage.Visible = False Me.CmdUserSheet.Visible = False Me.Range("A1") = "" Call BackTo Usf_Login.Show End IfEnd 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.SaveEnd SubPrivate Sub Workbook_Open() Usf_Login.ShowEnd Sub
代码解析：
（1）Line1~10，工作簿BeforeClose关闭前事件，调用BackTo过程，把工作表“Main”上的其他两个按钮隐藏，A1单元格清空。
（2）line12~14，工作簿Open打开事件，显示用户登录窗体Usf_Login。。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留个言、分享一下呗！感谢！