Username and Password VBA with the ability for user to change the password

Thanks that was very helpful...

Mike at Ozgrid kindly provided me with this code and I thought I should share it here to help others... I hoe you would find this helpful and it works great for me.

Linkt to Mikes reply is here - http://www.ozgrid.com/forum/showthread.php?t=187396

Also the spreadsheeet is attached

 Sub Workbook_Open() 
    If IsOKUser Then 
        If ThisWorkbook.Sheets("UserData").Visible = xlSheetVisible Then 
            MsgBox "you are an administrator" 
        Else 
            MsgBox "you are an authorized user" 
        End If 
    Else 
        MsgBox "You are not authorized to use this workbook" 
        ThisWorkbook.Close 
    End If 
     
End Sub 
 
Function IsOKUser() As Boolean 
    Dim uiUserName As String 
    Dim uiPW As String, uiVerifyPW As String 
    Dim rngUserNames As Range, rngUserFound As Range 
    Dim rngHistory As Range 
    Dim strPrompt As String 
    Dim i As Long, oneSheet As Worksheet 
     
    Dim maxTry As Long: maxTry = 2 
     
    With ThisWorkbook.Worksheets("UserData") 
        Set rngUserNames = .Columns(1) 
        Set rngHistory = .Columns("H:H") 
    End With 
     
    Rem hide sheets 
    Application.ScreenUpdating = False 
    With ThisWorkbook 
        With .Sheets("Welcome") 
            .Visible = xlSheetVisible 
            .Activate 
        End With 
        For Each oneSheet In .Sheets 
            If oneSheet.Name <> ActiveSheet.Name Then 
                oneSheet.Visible = xlSheetVeryHidden 
            End If 
        Next oneSheet 
    End With 
    Application.ScreenUpdating = True 
    Application.ScreenUpdating = False 
     
    Rem verify password 
    Do While (0 < maxTry) 
        IsOKUser = False 
        maxTry = maxTry - 1 
         
        uiUserName = Application.InputBox("Enter case insensitive UserName", Type:=2) 
        If uiUserName = "False" Then Exit Function: Rem cancel pressed 
        With rngUserNames.EntireColumn 
            Set rngUserFound = .Find(uiUserName, after:=.Cells(1, 1), MatchCase:=False, lookat:=xlWhole) 
        End With 
        If rngUserFound Is Nothing Then 
            Rem no matching username 
            MsgBox Application.Proper(uiUserName) & " is not an authorized username" 
        Else 
            uiPW = Application.InputBox("Enter case sensitive password", Type:=2) 
            If uiPW = "False" Then Exit Function: Rem canceled 
            IsOKUser = (uiPW = CStr(rngUserFound.Offset(0, 1).Value)) 
             'IsOKUser = (LCase(uiPW) = LCase(CStr(rngUserFound.Offset(0, 1).Value))): Rem case insensitive passwords
        End If 
         
        If IsOKUser Then 
            Rem user/password match 
            Application.ScreenUpdating = False 
            maxTry = 0 
             
            Rem reveal user 's sheets
            For i = 2 To 4 
                With rngUserFound.Offset(0, i) 
                    If .Value <> vbNullString Then 
                        ThisWorkbook.Sheets(.EntireColumn.Cells(1, 1).Value).Visible = xlSheetVisible 
                    End If 
                End With 
            Next i 
             
            Rem test If admin 
            If rngUserFound.Offset(0, 5).Value <> vbNullString Then 
                For Each oneSheet In ThisWorkbook.Sheets 
                    oneSheet.Visible = xlSheetVisible 
                Next oneSheet 
            End If 
             
            Rem record log-in 
            With rngHistory 
                With .Cells(.Rows.Count).End(xlUp).Offset(1, 0) 
                    .Value = rngUserFound.Value 
                    .Offset(0, 1).Value = Now 
                End With 
            End With 
            Application.ScreenUpdating = True 
             
            Rem New password 
            Do 
                strPrompt = "Enter a new password" & vbCr & "or press cancel or Return to not change pw." 
                uiPW = Application.InputBox(strPrompt, Default:=rngUserFound.Offset(0, 1).Value, Type:=2) 
                If uiPW = "False" Or uiPW = vbNullString Then Exit Function: Rem canceled 
                 
                If uiPW = rngUserFound.Offset(0, 1).Value Then 
                    Rem New password = old password 
                    uiVerifyPW = uiPW 
                Else 
                    strPrompt = "Enter your new password again" 
                    uiVerifyPW = Application.InputBox(strPrompt, Default:=vbNullString, Type:=2) 
                     
                    If uiVerifyPW = uiPW Then 
                        Rem entries match, password changed 
                        MsgBox "Password changed" 
                        rngUserFound.Offset(0, 1) = uiPW 
                    Else 
                        Rem New password verification mismatch 
                        MsgBox "Password verification entry failed. Try again." 
                    End If 
                End If 
            Loop Until uiPW = uiVerifyPW 
        Else 
            MsgBox "Authorization Failed. You have " & maxTry & " attempts left." 
        End If 
    Loop 
End Function 
 
Private Sub Workbook_BeforeClose(Cancel As Boolean) 
    Dim oneSheet As Worksheet, wasSaved As Boolean 
    Application.ScreenUpdating = False 
     
    With ThisWorkbook 
        wasSaved = .Saved 
         
        With .Sheets("Welcome") 
            .Visible = xlSheetVisible 
            .Activate 
        End With 
        For Each oneSheet In .Sheets 
            If oneSheet.Name <> ActiveSheet.Name Then 
                oneSheet.Visible = xlSheetVeryHidden 
            End If 
        Next oneSheet 
         
        If wasSaved Then 
            .Save 
        Else 
            If MsgBox("Save Changes", vbYesNo) = xlYes Then 
                .Save 
            Else 
                .Saved = True 
            End If 
        End If 
    End With 
    Application.ScreenUpdating = True 
End Sub

Thanks to Mike :-)