VBA to insert username in a cell

Option Explicit
Dim ws         As Worksheet
Dim cl         As Range
Dim rng        As Range
Dim bOK        As Boolean
Dim iCounta    As Integer
Dim sPW        As String
Dim sLevel     As String
Dim sUser      As String
Dim sMsg       As String
Dim a, b       As Integer
 
Const sTitle   As String = "Incorrect Password"
Const sStyle   As String = vbOKOnly + vbExclamation
 
 
Sub validatePW()
    On Error GoTo err_handler
   
    If Me.cboUser.Value = "Manager" And Me.tbxPW = Sheet1.Cells(4, 1).Value Then
        Me.cmdManage.Visible = True
        Exit Sub
    End If
   
    Select Case iCounta
        Case 1, 2, 3
            With Sheet1
                Set rng = .Range(.Cells(8, 1), .Cells(.Rows.Count, 1).End(xlUp))
                Set cl = rng.Find(sUser, LookIn:=xlValues)
            End With
            If cl.Offset(0, 1).Value <> Me.tbxPW.Text Then
                sMsg = "You have entered an incorrect Password" _
                       & vbNewLine & "Try again" & vbNewLine & _
                       "You have " & iCounta & " goes left"
                MsgBox sMsg, sStyle, sTitle
                With Me
                    .cboUser.Value = vbNullString
                    .tbxPW = vbNullString
                    .cboUser.SetFocus
                    Exit Sub
                End With
            ElseIf cl.Offset(0, 1).Value = Me.tbxPW.Text Then
                sLevel = cl.Offset(0, 2).Value
                MsgBox "Correct Information Entered.  Please Proceed.", vbOKOnly + _
                                                                        vbInformation, "Correct Information entered."
                Sheets("Splash").Visible = xlSheetVisible
                bOK = True
                If InStr(1, sLevel, ",", vbTextCompare) > 0 Then
                    a = 1
                    b = (InStr(1, sLevel, ",", vbTextCompare)) - 1
                    Do While True
                        Sheets(Mid(sLevel, a, b)).Visible = xlSheetVisible
                        If InStr(a + b, sLevel, ",", vbTextCompare) > 0 Then
                            a = InStr(a, sLevel, ",", vbTextCompare) + 1
                            b = InStr(a, sLevel, ",", vbTextCompare) - a
                        Else
                            Exit Do
                        End If
                    Loop
                Else
                    Sheets(sLevel).Visible = xlSheetVisible
                End If
                Unload Me
            End If
        Case 0
            MsgBox "You have tried three time incorrectly. WorkBook will now close" _
                   , vbOKOnly + vbExclamation, "Warning"
            bOK = True
            Unload Me
            Exit Sub
err_handler:
            'this line should be used in the final version
            '            ActiveWorkbook.Close SaveChanges:=False    'close without saving
    End Select
 
End Sub
 
Private Sub cmdManage_Click()
    Dim ws     As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws
    bOK = True
    Unload Me
End Sub
 
Private Sub cmdValidatePW_Click()
    sUser = Me.cboUser.Text
    sPW = Me.tbxPW.Text
    iCounta = iCounta - 1
 
    validatePW
End Sub
 
Private Sub UserForm_Initialize()
    iCounta = 3
    With Sheet1
        Me.cboUser.List = .Range(.Cells(8, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
    End With
    Me.cboUser.SetFocus
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If bOK Then GoTo theend
    If CloseMode = 0 Then Cancel = True
    MsgBox "Sorry, you must enter your password & username", vbExclamation, "Warning"
theend:
End Sub

Option Explicit
Option Compare Text
Dim ws         As Worksheet
Const MaxUses  As Long = 5    '<- change uses
Const wsWarningSheet As String = "Splash"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'hide all sheets except warning sheet
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = wsWarningSheet Then
            ws.Visible = True
        Else
            ws.Visible = xlVeryHidden
        End If
    Next
    'record opening in remote cell
    With Sheets(wsWarningSheet).Cells(Rows.Count, Columns.Count)
        .Value = .Value + 1
    End With
End Sub
 
 
Private Sub Workbook_Open()
    frmPW.Show
End Sub