Command Button Password Protect issue with VBA

[Serjape]

Let me start off by saying I absolutely suck at VBA. What you are looking at is months of work and luck. I have a command button that when pressed asked for password and when entered it will move data from one sheet to another based on criteria. It works! That's the good part, however, when you press button and DON'T enter password and instead cancel....it STILL moves the data?!?!

Dim pwdstate As Integer
Dim fle As String

Sub copy_Sun_Mon()
    Call pwdprotect
    If pwdstate = 0 Then
        Call copy_sheet1("Sunday", "Monday")
    End If
End Sub

Sub copy_Mon_Tue()
    Call pwdprotect
    If pwdstate = 0 Then
        Call copy_sheet1("Monday", "Tuesday")
    End If
End Sub

Sub copy_Tue_Wed()
    Call pwdprotect
    If pwdstate = 0 Then
        Call copy_sheet1("Tuesday", "Wednesday")
    End If
End Sub

Sub copy_Wed_Thu()
    Call pwdprotect
    If pwdstate = 0 Then
        Call copy_sheet1("Wednesday", "Thursday")
    End If
End Sub

Sub copy_Thu_Fri()
    Call pwdprotect
    If pwdstate = 0 Then
        Call copy_sheet1("Thursday", "Friday")
    End If
End Sub

Sub copy_Fri_Sat()
    Call pwdprotect
    If pwdstate = 0 Then
        Call copy_sheet1("Friday", "Saturday")
    End If
End Sub

Sub copy_Sat_Sun()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Call pwdprotect
    If pwdstate = 0 Then
        Set wb = ActiveWorkbook
        wb.Save
        Call copy_sheet2("Saturday", "Sunday")
    End If
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub Choose_File()

    Dim diaFolder As FileDialog
   
    Set diaFolder = Application.FileDialog(msoFileDialogFilePicker)
    diaFolder.AllowMultiSelect = False
    diaFolder.Show
   
    On Error GoTo ErrorHandler
    fle = diaFolder.SelectedItems(1)
    Set diaFolder = Nothing
   
    Exit Sub
   
ErrorHandler:
    fle = ""
    Exit Sub

End Sub

Sub pwdprotect()

Dim password As Variant
password = Application.InputBox("Enter Password", "Password Protected")
pwdstate = 0
Select Case password
    Case Is = False
        Exit Sub
    Case Is = "CPC"
        'continue
        pwdstate = 0
    Case Else
        MsgBox "Incorrect Password"
        pwdstate = 1
End Select

End Sub

Sub copy_sheet1(S1 As String, S2 As String)

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set wp = wb.Sheets("Parameters")

For i = 1 To wb.Sheets.Count
    If wb.Sheets(i).Name = S1 Then
        Set w1 = wb.Sheets(i)
    ElseIf wb.Sheets(i).Name = S2 Then
        Set w2 = wb.Sheets(i)
    End If
Next

w1.Unprotect "CPC"
w2.Unprotect "CPC"
w1.Range("ZZ99") = 1
w2.Range("ZZ99") = 1

For i = 15 To 185
    If LCase(w1.Cells(i, 9)) = "open" Or LCase(w1.Cells(i, 9)) = "down" Or LCase(w1.Cells(i, 9)) = "rescheduled" Or LCase(w1.Cells(i, 9)) = "pending" Then
        fromln = i
        fromln = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 1)
        toln = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 2)
        If i <= toln Then
            fromcol = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 3)
            tocol = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 4)
            For j = fromln To toln
                If w2.Cells(j, 9) = "" Then
                    w2.Range(fromcol & j & ":" & tocol & j).Value = w1.Range(fromcol & i & ":" & tocol & i).Value
                    If fromcol = "B" Then
                        w1.Range(fromcol & i).Copy w2.Range(fromcol & j)
                    End If
                    w2.Rows(j).RowHeight = w1.Rows(i).RowHeight
                    Exit For
                End If
            Next
        End If
    End If
Next
ActiveSheet.Range("ZZ99") = ""
w1.Unprotect "CPC"
w2.Unprotect "CPC"
w1.Range("ZZ99") = 0
w2.Range("ZZ99") = 0
w1.Protect "CPC"
w2.Protect "CPC"

w2.Activate

Application.ScreenUpdating = True

End Sub
Sub copy_sheet2(S1 As String, S2 As String)

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set wp = wb.Sheets("Parameters")

Call Choose_File
If fle <> "" Then
    Set wb2 = Workbooks.Open(fle)
Else
    Exit Sub
End If
       
For i = 1 To wb.Sheets.Count
    If wb.Sheets(i).Name = S1 Then
        Set w1 = wb.Sheets(i)
    End If
Next
For i = 1 To wb2.Sheets.Count
    If wb2.Sheets(i).Name = S2 Then
        Set w2 = wb2.Sheets(i)
    End If
Next

w1.Unprotect "CPC"
w1.Range("ZZ99") = 1
w2.Unprotect "CPC"
w2.Range("ZZ99") = 1

For i = 15 To 185
    If LCase(w1.Cells(i, 9)) = "open" Or LCase(w1.Cells(i, 9)) = "down" Or LCase(w1.Cells(i, 9)) = "rescheduled" Or LCase(w1.Cells(i, 9)) = "pending" Then
        fromln = i
        fromln = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 1)
        toln = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 2)
        If i <= toln Then
            fromcol = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 3)
            tocol = Application.WorksheetFunction.VLookup(fromln, wp.Range("A:D"), 4)
            For j = fromln To toln
                If w2.Cells(j, 9) = "" Then
                    w2.Range(fromcol & j & ":" & tocol & j).Value = w1.Range(fromcol & i & ":" & tocol & i).Value
                    If fromcol = "B" Then
                        w1.Range(fromcol & i).Copy w2.Range(fromcol & j)
                    End If
                    w2.Rows(j).RowHeight = w1.Rows(i).RowHeight
                    Exit For
                End If
            Next
        End If
    End If
Next


w1.Unprotect "CPC"
w1.Range("ZZ99") = 0
w1.Protect "CPC"
w2.Unprotect "CPC"
w2.Range("ZZ99") = 0
w2.Protect "CPC"

wb.Close
wb2.Save
wb2.Activate
w2.Activate

Application.ScreenUpdating = True

End Sub
Sub autofit()

Set wb = ActiveWorkbook

    For i = 1 To wb.Sheets.Count
        If InStr(LCase(wb.Sheets(i).Name), "day") <> 0 And wb.Sheets(i).Visible = True Then
            '15-26    F,G,H
            wb.Sheets(i).Range("F15:H26").WrapText = True
            '27-31    B,C,D,E,F,G,H
            wb.Sheets(i).Range("B27:H31").WrapText = True
            '33-36    F,G,H
            wb.Sheets(i).Range("F33:H36").WrapText = True
            '38-45    F,G,H
            wb.Sheets(i).Range("F38:H45").WrapText = True
            '55-59    E,F
            wb.Sheets(i).Range("D47:F53").WrapText = True
            wb.Sheets(i).Range("E55:F59").WrapText = True
            '61-66    F,G,H
            wb.Sheets(i).Range("F61:H66").WrapText = True
            '67-71    E,F,G,H
            wb.Sheets(i).Range("E67:H71").WrapText = True
            '73-78    F,G,H
            wb.Sheets(i).Range("F73:H78").WrapText = True
            '79-81    E,F,G,H
            wb.Sheets(i).Range("E79:H81").WrapText = True
            '83-88    F,G,H
            wb.Sheets(i).Range("F83:H88").WrapText = True
            '89-91    E,F,G,H
            wb.Sheets(i).Range("E89:H91").WrapText = True
            '137-143  F,G,H
            wb.Sheets(i).Range("F137:H143").WrapText = True
            '145-149  F,G,H
            wb.Sheets(i).Range("F145:H149").WrapText = True
            '151-155  F,G,H
            wb.Sheets(i).Range("F151:H155").WrapText = True
        End If
    Next
   
End Sub

 

[HaHoBe]

Hi Serapje,

try the changed code for checking entered passwords:

Sub pwdprotect()

Dim passpwdstateword As Variant
passpwdstateword = Application.InputBox("Enter Password", "Password Protected")
pwdstate = 0
Select Case passpwdstateword
  Case Is = False
    MsgBox "Process cancelled"
    pwdstate = 1
    End
  Case Is = "CPC"
    'continue
    pwdstate = 0
  Case Else
    MsgBox "Incorrect Password"
    pwdstate = 1
End Select

End Sub

Ciao,
Holger

 

[HaHoBe]

Hi Serapje,

I had a look at the entire code by now and somehow condensed it (and by that may have made a mistake so please try this code on a copy of your data first).

Instead of having several procedures to decide which days to copy (7) and which way to do so (2) you will only find one procedure for each. Choose_File was integrated but I left out autofit (I would recommend to rename that procedure as AutoFit is a Function applied to the Range-Object).

Option Explicit
Option Base 1

Dim mintPwdState As Integer
Const mstrPW As String = "CPC"
'

'https://www.mrexcel.com/board/threads/command-button-password-protect-issue-with-vba.1220827/

Sub procCheckPW()
'/// checking entered password to real one
  Dim varRetPwd     As Variant
  
  varRetPwd = Application.InputBox("Enter Password", "Password Protected")
  mintPwdState = 0
  Select Case varRetPwd
    Case False
      MsgBox "Process canceled"
      mintPwdState = 1
      Exit Sub
    Case mstrPW
      '/// only the exact match will be recognized, cpc or CPc will not make it
      'continue
      mintPwdState = 0
    Case Else
      MsgBox "Incorrect Password"
      mintPwdState = 1
  End Select

End Sub

Sub procCallCopySheets()
  Dim strMsg            As String
  Dim lngRet            As Long
  Dim varArrW           As Variant
  Dim strSheetFrom      As String
  Dim strSheetTo        As String
  
  Const cstrSun         As String = "Sunday"
  Const cstrMon         As String = "Monday"
  Const cstrTue         As String = "Tuesday"
  Const cstrWed         As String = "Wednesday"
  Const cstrThu         As String = "Thursday"
  Const cstrFri         As String = "Friday"
  Const cstrSat         As String = "Saturday"
  Const cstrDiv         As String = " ---> "
  
  varArrW = Array(cstrSun, cstrMon, cstrTue, cstrWed, cstrThu, cstrFri, cstrSat, cstrSun)
  
  Call procCheckPW
  If mintPwdState = 0 Then
    strMsg = "Choose per number which sheets to copy:" & vbCrLf & vbTab & _
              "1 " & cstrSun & cstrDiv & cstrMon & vbCrLf & vbTab & _
              "2 " & cstrMon & cstrDiv & cstrTue & vbCrLf & vbTab & _
              "3 " & cstrTue & cstrDiv & cstrWed & vbCrLf & vbTab & _
              "4 " & cstrWed & cstrDiv & cstrThu & vbCrLf & vbTab & _
              "5 " & cstrThu & cstrDiv & cstrFri & vbCrLf & vbTab & _
              "6 " & cstrFri & cstrDiv & cstrSat & vbCrLf & vbTab & _
              "7 " & cstrSat & cstrDiv & cstrSun & vbCrLf & vbTab & _
              "0 or Cancel to end procedure"
try_again:
    lngRet = Application.InputBox(strMsg, "What to copy?", Type:=1)
    Select Case lngRet
      Case 1 To 7
        strSheetFrom = varArrW(lngRet)
        strSheetTo = varArrW(lngRet + 1)
        Call procCopySheets(strSheetFrom, strSheetTo)
      Case 0
        End
      Case Else
        If MsgBox("Choice is not within 1 to 7 or Cancel. Would you like to try again?", _
                vbYesNo, "Cancel or continue?") = vbYes Then
          GoTo try_again
        Else
          End
        End If
    End Select
  End If
End Sub

Sub procCopySheets(strSheetFrom As String, strSheetTo As String)

  Dim wbAct           As Workbook
  Dim wbSun           As Workbook
  Dim wsParam         As Worksheet
  Dim wsFrom          As Worksheet
  Dim wsTo            As Worksheet
  Dim lngCounter      As Long
  Dim lngLoop         As Long
  Dim lngRowStart     As Long
  Dim lngRowEnd       As Long
  Dim strColStart     As String
  Dim strColEnd       As String
  Dim diaFolder       As FileDialog
  Dim strFile         As String
  
  Application.ScreenUpdating = False
  
  On Error GoTo err_here
  Set wbAct = ActiveWorkbook
  Set wsParam = wbAct.Sheets("Parameters")
  
  On Error GoTo err_here
  Set wsFrom = wbAct.Sheets(strSheetFrom)
  On Error GoTo 0
  Select Case strSheetTo
    Case "Sunday"
      Set diaFolder = Application.FileDialog(msoFileDialogFilePicker)
      With diaFolder
        .AllowMultiSelect = False
        If .Show = -1 Then strFile = .SelectedItems(1)
      End With
      Set diaFolder = Nothing
      If strFile = "" Then
        MsgBox "No file chosen, ending procedure.", vbInformation, "End here"
        End
      Else
        Set wbSun = Workbooks.Open(strFile)
        On Error GoTo err_here
        Set wsTo = wbSun.Sheets(strSheetTo)
        On Error GoTo 0
      End If
    Case Else
      On Error GoTo err_here
      Set wsTo = wbAct.Sheets(strSheetTo)
      On Error GoTo 0
  End Select
  
  If wsFrom Is Nothing Then GoTo end_here
  If wsTo Is Nothing Then GoTo end_here
  
  wsFrom.Unprotect mstrPW
  wsTo.Unprotect mstrPW
  wsFrom.Range("ZZ99") = 1
  wsTo.Range("ZZ99") = 1
  
  For lngCounter = 15 To 185
    Select Case LCase(wsFrom.Cells(lngCounter, 9).Value)
      Case "open", "down", "rescheduled", "pending"
        lngRowStart = lngCounter
        '/// not really sure why you would use a VLookup in the matrix to find the value you entered.
        '/// If that value is not found all other values will hold wrong values as well if any at all
'        lngRowStart = Application.WorksheetFunction.VLookup(lngRowStart, wsParam.Range("A:D"), 1)
       If WorksheetFunction.CountIf(wsParam.Range("A:A"), lngRowStart) = 1 Then
          lngRowEnd = Application.WorksheetFunction.VLookup(lngRowStart, wsParam.Range("A:D"), 2)
          If lngCounter <= lngRowEnd Then
            strColStart = Application.WorksheetFunction.VLookup(lngRowStart, wsParam.Range("A:D"), 3)
            strColEnd = Application.WorksheetFunction.VLookup(lngRowStart, wsParam.Range("A:D"), 4)
            For lngLoop = lngRowStart To lngRowEnd
              If wsTo.Cells(lngLoop, 9) = "" Then
                wsTo.Range(strColStart & lngLoop & ":" & strColEnd & lngLoop).Value = _
                    wsFrom.Range(strColStart & lngCounter & ":" & strColEnd & lngCounter).Value
                If strColStart = "B" Then
                  wsFrom.Range(strColStart & lngCounter).Copy wsTo.Range(strColStart & lngLoop)
                End If
                wsTo.Rows(lngLoop).RowHeight = wsFrom.Rows(lngCounter).RowHeight
                Exit For
              End If
            Next lngLoop
          End If
        Else
          MsgBox lngRowStart & " is not found in Sheet Parameters"
          Debug.Print "Check row " & lngRowStart
          '/// code will continue here without any copy but leave information in the Immediate Window
        End If
      Case Else
    End Select
  Next lngCounter
  
  wsFrom.Range("ZZ99") = 0
  wsTo.Range("ZZ99") = 0
  wsFrom.Protect mstrPW
  wsTo.Protect mstrPW
  
  If Not wbSun Is Nothing Then
    wbAct.Close
    wbSun.Save
    wbSun.Activate
  End If
  wsTo.Activate
  
end_here:
  Set wsTo = Nothing
  Set wsFrom = Nothing
  Set wsParam = Nothing
  Set wbSun = Nothing
  Set wbAct = Nothing
  Application.ScreenUpdating = True
  Exit Sub
  
err_here:
  MsgBox "An error occurred. Please find more information in the Immediate Window", _
          vbExclamation, "Error"
  Debug.Print "Error Number: " & Err.Number
  Debug.Print "Error Description: " & Err.Description
  Err.Clear
  On Error GoTo 0
  Resume end_here

End Sub

Ciao,
Holger

 

[dmt32]

I have a command button that when pressed asked for password and when entered it will move data from one sheet to another based on criteria. It works! That's the good part, however, when you press button and DON'T enter password and instead cancel....it STILL moves the data?!?!

Hi,
I would suggest that you change your password Sub to a Function & call it from within your copy_sheet code negating the need for all those If tests in your other procedures

Place in a standard module

Function pwdprotect(Optional ByVal Password As String) As Boolean
    Dim Entry       As Variant
    Const strPrompt As String = "Incorrect Password"
    Do
    Entry = Application.InputBox("Enter Password", "Password Protected")
    'cancel pressed
    If Entry = False Then Exit Function
    If Entry <> Password Then MsgBox strPrompt, 48, strPrompt
    Loop Until Entry = Password
    pwdprotect = True
End Function

The function has one optional parameter "Password" you pass the required value to. This is then tested against user entry & if match, Function returns True.
otherwise False which includes the Cancel button press.
The function is standalone and can be used in other places in your project if required.

Place lines of code shown in your Copy Sheet Code

Sub copy_sheet1(S1 As String, S2 As String)

   Const strPassword As String = "CPC"
    'incorrect password exit sub
    If Not pwdprotect(strPassword) Then Exit Sub

'rest of code

Note: You should replace all your hard coded Password string values "CPC" in the procedure with the constant strPassword

Update Your calling codes by removing all the If tests.

Sub copy_Sun_Mon()
  Call copy_sheet1("Sunday", "Monday")
End Sub

Hope Helpful

Dave

 

[Serjape]

The command button and is on each sheet of 7 sheets. I am not sure if that makes a difference. I will try what you suggest HaHoBe. IS what you are suggesting dmt32 so that password can be changed in future and not be married to CPC?

 

[dmt32]

IS what you are suggesting dmt32 so that password can be changed in future and not be married to CPC?

The password is specified in the constant which is passed to the Function

    Const strPassword As String = "CPC"

and Yes, providing you have updated your code replacing the hard coded password "CPC" with the constant strPassword you just change the password in the one place as required.

Dave

 

[HaHoBe]

Hi Serapje,

in my code you would need to distinguish between the sheets by making a choice. This could be altered to start the correct macro due to the sheet name without making any choice. I would prefer to work with the Codenames of the sheets (only seen from within the VBE or when using code) and not the worksheet tab names. My strategy was to only have one button and work from there but that needs the sheetnames to be identical to the names of the days. In any case you should use either concept provided for the check of the password.

And as I'm curious about this: is it only a small number of people who know about the password as that would allow the Workbook_Open-event to check if any password would be needed for that person.

Ciao,
Holger