issue with Change-event being activated by copying a row.

[vilas desai]

Dear Sirs,

I have two issues with change event procedure in the MasterList.

1. When I copy a row to a new blank row, sometimes cell D senses a change and copies data into the destination. If this can happen by purpose, I would prefer it, but not with spurious sensing of change event. If this cannot happen by purpose, then I would like the macro not accept copy as a change (second choice)or I would like to avoid a row being copied in the first place.(third choice)

2. Like other rows, Row 5 can also be deleted completely after deleting cell D using hard key on keyboard. If Row 5 is deleted I would lose my formulas too.
Choice 1: I would like the formulas to Macros
Choice 2: How can I prevent the formulas being deleted
Choice 3: how can i prevent row 5 from being deleted.

The file is too large to be sent in this forum, so I am copying the code.

Code: Select all

Option Explicit

Dim mbNoEvent As Boolean

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
        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
    If vPrevValue <> "" Then
        lngCount = Application.WorksheetFunction.CountIf(Me.Range("D5:" & Target.Address), vPrevValue)
        ' Get info about previous source range
        lngIndex = Application.WorksheetFunction.Match(vPrevValue, wshList.Range("A:A"), 0)
        strSource = wshList.Range("B" & lngIndex)
        Set wshSource = Worksheets(strSource)
        strSource = wshList.Range("C" & lngIndex)
        Set rngSource = wshSource.Range(strSource)
        lngRowCount = rngSource.Rows.Count
        ' Get info about previous destination
        strDestination = wshList.Range("D" & lngIndex)
        Set wshDestination = Worksheets(strDestination)
        strDestination = wshList.Range("E" & lngIndex)
        Set rngDestination = wshDestination.Range(strDestination).Offset(lngCount * lngRowCount, 0)
        Set rngDestination = rngDestination.Resize(rngSource.Rows.Count, rngSource.Columns.Count)
        ' Delete
        rngDestination.Delete Shift:=xlShiftUp
    End If
    If vCurValue <> "" Then
        lngCount = Application.WorksheetFunction.CountIf(Me.Range("D5:" & Target.Address), vCurValue) - 1
        ' Get info about current source range
        lngIndex = Application.WorksheetFunction.Match(vCurValue, wshList.Range("A:A"), 0)
        strSource = wshList.Range("B" & lngIndex)
        Set wshSource = Worksheets(strSource)
        strSource = wshList.Range("C" & lngIndex)
        Set rngSource = wshSource.Range(strSource)
        lngRowCount = rngSource.Rows.Count
        ' Get info about current destination
        strDestination = wshList.Range("D" & lngIndex)
        Set wshDestination = Worksheets(strDestination)
        strDestination = wshList.Range("E" & lngIndex)
        Set rngDestination = wshDestination.Range(strDestination).Offset(lngCount * lngRowCount, 0)
        Set rngDestination = rngDestination.Resize(rngSource.Rows.Count, rngSource.Columns.Count)
        strDestination = rngDestination.Address
        rngDestination.Insert Shift:=xlDown
        Set rngDestination = rngDestination.Worksheet.Range(strDestination)
        ' Copy
        rngSource.Copy Destination:=rngDestination
        rngSource.Copy
        rngDestination.PasteSpecial Paste:=xlPasteColumnWidths
        Call UpdateValues(Target, rngDestination, wshList.Range("F" & lngIndex))
        Call CheckCol_E(Target)
    Else
        Target.Offset(0, 1) = ""
    End If

ExitHandler:
    mbNoEvent = False
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Private Sub UpdateValues(ByVal MasterListColD As Range, ByVal rngDestination As Range, ByVal CpyRowOffsetadd As Long)
    ' rngDestination(CpyRowOffsetadd, 1) = "=if(" & _
    MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 3).Address & "=""""," _
    & MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 2).Address & "," & _
    MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 2).Address & "&""-""&" & _
    MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 3).Address & ")"

    'P&ID Ref
    rngDestination(CpyRowOffsetadd + 1, 6) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, -3).Address

    'Service Area
    rngDestination(CpyRowOffsetadd + 2, 6) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, -2).Address

    'Service Equipment
    rngDestination(CpyRowOffsetadd + 3, 6) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, -1).Address

    'Device
    rngDestination(CpyRowOffsetadd + 4, 6) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 0).Address

    'Device Function
    rngDestination(CpyRowOffsetadd + 5, 6) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 1).Address

    'Measurement
    rngDestination(CpyRowOffsetadd + 6, 6) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 2).Address

    'Loop Number
    rngDestination(CpyRowOffsetadd + 1, 20) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 4).Address

    'Jn Box ID
    rngDestination(CpyRowOffsetadd + 2, 20) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 7).Address

    'Device tag
    rngDestination(CpyRowOffsetadd + 4, 20) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 6).Address

    'Cable tag
    rngDestination(CpyRowOffsetadd + 5, 20) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 8).Address

    'IO tag
    rngDestination(CpyRowOffsetadd + 6, 20) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 20).Address

    'M.R ID
    rngDestination(CpyRowOffsetadd + 3, 20) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 9).Address

'------------------------------------------------------------------------------------
    'PLC Panel ID
    rngDestination(CpyRowOffsetadd + 1, 30) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 12).Address

    'PLC / DCS ID
    rngDestination(CpyRowOffsetadd + 2, 28) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 13).Address

    'PLC RAck Number
    rngDestination(CpyRowOffsetadd + 3, 28) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 16).Address

    'Slot Number
    rngDestination(CpyRowOffsetadd + 3, 32) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 17).Address

    'Channel Number
    rngDestination(CpyRowOffsetadd + 4, 28) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 18).Address

    'IO Type
    rngDestination(CpyRowOffsetadd + 5, 28) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 19).Address

    'No. of Wires
    rngDestination(CpyRowOffsetadd + 6, 29) = "=" & MasterListColD.Worksheet.Name _
        & "!" & MasterListColD.Offset(0, 5).Address

    Application.CutCopyMode = False
End Sub


Private Sub CheckCol_E(ByVal MasterListColD As Range)
    Dim ColorMark As Boolean
    Dim MasterListColE As Range
    Dim cel As Range
    Set MasterListColE = MasterListColD.Offset(0, 1)
    ColorMark = True
    If MasterListColD.Value = "" Or MasterListColE.Value = "" Then
        With MasterListColE.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 3
        End With
    Exit Sub
    End If

    For Each cel In Application.Range(MasterListColD.Value)
        If cel.Value = MasterListColE.Value Then
            ColorMark = False
            Exit For
        End If
    Next

    If ColorMark Then
        With MasterListColE.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 3
        End With
    Else
        MasterListColE.Borders.LineStyle = xlNone
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Range("K5:K" & Rows.Count & ",N5:N" & Rows.Count & _
            ",P5:P" & Rows.Count), Target) Is Nothing Then
        frmSelect.Show
    End If
End Sub

Please help me on this.

Best regards
Vilas Desai

[Jan Karel Pieterse]

Hi Vilas,

You can detect whether one cell has changed or more than one and exit the sub if that is the case:

Code: Select all

If Target.Cells.Count >1 Then Exit sub

[vilas desai]

Hi Jan,
It is such a privilege and Honor to be receiving your reply. In fact it is you who introduced me to Hans and Eileen's Lounge. Hans has been helpful beyond explanation. Thank you for that.
I will copy this into my code and see how it works.
Best regards
Vilas Desai

[vilas desai]

Hi Jan
I added the code right after the Dim statements. I could copy successfully rows without spurious change events. But I landed up with other issues - like the formulas not being copied or not evaluating the result I dont know what exactly). Also the dependent drop down list does not open up the options.
I know you had a great idea about this project last year or so before you guided me to Eileen's lounge, but there have been several changes to that code. So I would guess any new addition may affect the rest of the codes. Do you want me to send you the file by email or do you advise to refer back to Hans?
Best regards
Vilas Desai

[HansV]

You could protect the sheet:

Step 1:
- Select the cells that the user should be able to edit.
- Press Ctrl+1 to activate the Format Cells dialog.
- Activate the Protection tab.
- Clear the Locked check box.
- Click OK.

Step 2:
- On the Review tab of the ribbon, click Protect Sheet.
- If you wish, enter a password for unlocking the sheet.
- Click OK. If you specified a password, you will have to confirm it.

Once the sheet has been protected, users won't be able to insert or delete rows, so you will have to provide macros to do that, and make them available through command buttons and/or keyboard shortcuts.
The macros can check whether the action is allowed, and if so, unprotect the sheet, perform the action, then protect the sheet again.

For example:

Code: Select all

Sub DeleteRow()
    If ActiveCell.Row <= 5 Then
        MsgBox "You're not allowed to delete rows 1 to 5", vbInformation
        Exit Sub
    End If
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="secret"
    ActiveCell.EntireRow.Delete
    ActiveSheet.Protect Password:="secret"
    Application.EnableEvents = True
End Sub

[vilas desai]

Thank you, Hans. I get an error
Error: Cannot use Table Functionality on a Protected Sheet The cursor moves to the next row at the end of table but the table row is not copied.

[HansV]

I don't have time to test now, but does it help if you tick the check box "Insert rows" in the Protect Sheet dialog, and if you change the line

Code: Select all

    ActiveSheet.Protect Password:="secret"

to

Code: Select all

    ActiveSheet.Protect Password:="secret", AllowInsertingRows:=True