VBA to insert username in a cell


New member
Jun 6, 2013
Reaction score
I have a workbook that requires users to enter a username and password in order to open it.

I want to enter the Login name that is entered into cell D7 of Sheet1 (Hide this Sheet).

I am looking for some help in adding a suitable line or bit of code that will do this.

The VBA Code is as follows:

Forms - VBA

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
                    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
                            Exit Do
                        End If
                    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
            '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
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
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"
End Sub
Workbook vba

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
            ws.Visible = xlVeryHidden
        End If
    'record opening in remote cell
    With Sheets(wsWarningSheet).Cells(Rows.Count, Columns.Count)
        .Value = .Value + 1
    End With
End Sub
Private Sub Workbook_Open()
End Sub

Can anyone please help?