Add Password level to change history

[vilas desai]

Dear Hans,

Thank you.
There are two codes - 1. named "Change History" in a standard module and
2. found in MasterSheet worksheet change event code module

The two codes are as below, Where do you want me to insert the above two codes.
Also, as you are aware, before the changes are logged a password is asked. Does the code take care of this too. (not asking password at all since the changes are not logged)

Please advise
Best regards
Vilas Desai

Code: Select all

Sub SetHistory(varUser, vPrevValue, vCurValue, sAddress)
    Dim wshHist As Worksheet
    Dim r As Long
    Set wshHist = Worksheets("CHANGE_HISTORY")
    r = wshHist.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    wshHist.Cells(r, 1).Value = Now
    wshHist.Cells(r, 2).Value = varUser
    wshHist.Cells(r, 4).Value = vPrevValue
    wshHist.Cells(r, 5).Value = vCurValue
    wshHist.Cells(r, 6).Value = sAddress
End Sub

Code: Select all

Sub SetHistory(varUser, vPrevValue, vCurValue, sAddress)
    Dim wshHist As Worksheet
    Dim r As Long
    Set wshHist = Worksheets("CHANGE_HISTORY")
    r = wshHist.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    wshHist.Cells(r, 1).Value = Now
    wshHist.Cells(r, 2).Value = varUser
    wshHist.Cells(r, 4).Value = vPrevValue
    wshHist.Cells(r, 5).Value = vCurValue
    wshHist.Cells(r, 6).Value = sAddress
End Sub

[HansV]

You posted the same code twice.

[vilas desai]

Sorry about that. Here it is

Code: Select all

 Dim current_row As Long
    Dim column_numbers As Variant
    Dim col_counter As Long
    Static Exempt_Range As Range
    
    If mbNoEvent Then Exit Sub
    
    Dim prp As DocumentProperty
    ' Get the LogChanges property
    Set prp = ThisWorkbook.CustomDocumentProperties("LogChanges")
    ' Get out if logging is disabled
    If prp.Value = False Then Exit Sub
    
    
    If Target.Row < 5 Or Target.Column > 27 Then Exit Sub
    If Target.Address = ActiveSheet.ListObjects(1).HeaderRowRange.Offset(ActiveSheet.ListObjects(1).ListRows.Count).Address _
        And Target.Rows.Count = 1 Then
        current_row = Target.Row
        column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
        Set Exempt_Range = Nothing
        For col_counter = LBound(column_numbers) To UBound(column_numbers)
            If Exempt_Range Is Nothing Then
               Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
            Else
               Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
            End If
        Next
        Exit Sub
    End If
    
    If Target.Address = Target.EntireRow.Address Then Exit Sub
    If Exempt_Range Is Nothing Then
       current_row = Target.Row
       column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
       Set Exempt_Range = Nothing
       For col_counter = LBound(column_numbers) To UBound(column_numbers)
           If Exempt_Range Is Nothing Then
              Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
           Else
              Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
           End If
       Next
    End If
    

[HansV]

You didn't post the code that calls SetHistory.

[vilas desai]

Ok, here it is

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vPrevValue As Variant
    Dim vCurValue As Variant
    Dim lngIndex As Long
    Dim strSource As String
    Dim strDestination As String
    Dim strList As String
    Dim wshSource As Worksheet
    Dim wshDestination As Worksheet
    Dim wshList As Worksheet
    Dim rngSource As Range
    Dim rngDestination As Range
    Dim lngRowCount As Long
    Dim lngCount As Long
    Dim wshDV As Worksheet
    Dim strPW As String
    Dim varUser As Variant

    Dim current_row As Long
    Dim column_numbers As Variant
    Dim col_counter As Long
    Static Exempt_Range As Range
    
    If mbNoEvent Then Exit Sub
    
    Dim prp As DocumentProperty
    ' Get the LogChanges property
    Set prp = ThisWorkbook.CustomDocumentProperties("LogChanges")
    ' Get out if logging is disabled
    If prp.Value = False Then Exit Sub
    
    
    If Target.Row < 5 Or Target.Column > 27 Then Exit Sub
    If Target.Address = ActiveSheet.ListObjects(1).HeaderRowRange.Offset(ActiveSheet.ListObjects(1).ListRows.Count).Address _
        And Target.Rows.Count = 1 Then
        current_row = Target.Row
        column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
        Set Exempt_Range = Nothing
        For col_counter = LBound(column_numbers) To UBound(column_numbers)
            If Exempt_Range Is Nothing Then
               Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
            Else
               Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
            End If
        Next
        Exit Sub
    End If
    
    If Target.Address = Target.EntireRow.Address Then Exit Sub
    If Exempt_Range Is Nothing Then
       current_row = Target.Row
       column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
       Set Exempt_Range = Nothing
       For col_counter = LBound(column_numbers) To UBound(column_numbers)
           If Exempt_Range Is Nothing Then
              Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
           Else
              Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
           End If
       Next
    End If
    
    If Not (Application.Intersect(Target, Exempt_Range) Is Nothing) Then Exit Sub

    If Target.Count > 1 Then
        Application.EnableEvents = False
        Application.Undo
        MsgBox "Multiple cell changes are Not allowed.", vbExclamation
        Application.EnableEvents = True
        Exit Sub
    End If

    On Error GoTo ErrHandler
    mbNoEvent = True

    ' Get previous and current value
    vCurValue = Target.Value
    Application.EnableEvents = False
    Application.Undo
    vPrevValue = Target.Value
    If vPrevValue = "" Then
        Target.Value = vCurValue
    ElseIf vPrevValue = vCurValue Then
        ' Ignore
    Else
        strPW = InputBox("Enter your password")
        Set wshDV = Worksheets("DV")
        varUser = Application.VLookup(strPW, wshDV.Range("PasswordList"), 2, False)
        If IsError(varUser) Then
            MsgBox "Password invalid. Change not allowed!", vbCritical
            GoTo ExitHandler
        End If
        Target.Value = vCurValue
        Call SetHistory(varUser, vPrevValue, vCurValue, Target.Address)
    End If
    Application.EnableEvents = True

    If Intersect(Target, Me.Range("D:D")) Is Nothing Then
        If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
            Call CheckCol_E(Intersect(Target, Me.Range("E:E")).Offset(0, -1))
        End If
        GoTo ExitHandler
    End If

    Set wshList = Worksheets("List")
    If vCurValue = vPrevValue Then
        GoTo ExitHandler
    End If

[HansV]

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vPrevValue As Variant
    Dim vCurValue As Variant
    Dim lngIndex As Long
    Dim strSource As String
    Dim strDestination As String
    Dim strList As String
    Dim wshSource As Worksheet
    Dim wshDestination As Worksheet
    Dim wshList As Worksheet
    Dim rngSource As Range
    Dim rngDestination As Range
    Dim lngRowCount As Long
    Dim lngCount As Long
    Dim wshDV As Worksheet
    Dim strPW As String
    Dim varUser As Variant
    Dim current_row As Long
    Dim column_numbers As Variant
    Dim col_counter As Long
    Static Exempt_Range As Range

    If mbNoEvent Then Exit Sub

    If Target.Row < 5 Or Target.Column > 27 Then Exit Sub
    If Target.Address = ActiveSheet.ListObjects(1).HeaderRowRange.Offset(ActiveSheet.ListObjects(1).ListRows.Count).Address _
        And Target.Rows.Count = 1 Then
        current_row = Target.Row
        column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
        Set Exempt_Range = Nothing
        For col_counter = LBound(column_numbers) To UBound(column_numbers)
            If Exempt_Range Is Nothing Then
               Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
            Else
               Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
            End If
        Next
        Exit Sub
    End If

    If Target.Address = Target.EntireRow.Address Then Exit Sub
    If Exempt_Range Is Nothing Then
       current_row = Target.Row
       column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
       Set Exempt_Range = Nothing
       For col_counter = LBound(column_numbers) To UBound(column_numbers)
           If Exempt_Range Is Nothing Then
              Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
           Else
              Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
           End If
       Next
    End If

    If Not (Application.Intersect(Target, Exempt_Range) Is Nothing) Then Exit Sub

    If Target.Count > 1 Then
        Application.EnableEvents = False
        Application.Undo
        MsgBox "Multiple cell changes are Not allowed.", vbExclamation
        Application.EnableEvents = True
        Exit Sub
    End If

    On Error GoTo ErrHandler
    mbNoEvent = True

    ' Get previous and current value
    vCurValue = Target.Value
    Application.EnableEvents = False
    Application.Undo
    vPrevValue = Target.Value
    If vPrevValue = "" Then
        Target.Value = vCurValue
    ElseIf vPrevValue = vCurValue Then
        ' Ignore
    Else
        Dim prp As DocumentProperty
        ' Get the LogChanges property
        Set prp = ThisWorkbook.CustomDocumentProperties("LogChanges")
        ' Only log changes if enabled
        If prp.Value = True Then
            strPW = InputBox("Enter your password")
            Set wshDV = Worksheets("DV")
            varUser = Application.VLookup(strPW, wshDV.Range("PasswordList"), 2, False)
            If IsError(varUser) Then
                MsgBox "Password invalid. Change not allowed!", vbCritical
                GoTo ExitHandler
            End If
            Target.Value = vCurValue
            Call SetHistory(varUser, vPrevValue, vCurValue, Target.Address)
        Else
            Target.Value = vCurValue
        End If
    End If
    Application.EnableEvents = True

    If Intersect(Target, Me.Range("D:D")) Is Nothing Then
        If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
            Call CheckCol_E(Intersect(Target, Me.Range("E:E")).Offset(0, -1))
        End If
        GoTo ExitHandler
    End If

    Set wshList = Worksheets("List")
    If vCurValue = vPrevValue Then
        GoTo ExitHandler
    End If