Inserting a row in a protected worksheet

[vilas desai]

Dear Sirs,

The change event worksheet code produced below prohibits the user from selection of multiple cells (rows or cols). So when I right click on a row number and then hit the insert key, I get a message saying this operation is not allowed. My request is to modify this code to ONLY allow row insertion and no other operation when multiple cells are selected.

Also, I want the following two operations to be disallowed
1. Selection of all cells in the worksheet by clickinh on the triangular button at the crossing of the col and row rulers on extreme right side and also by using arrow keys to go to the bottomn of the sheet.

2. Undo / Redo operation by using the undo / redo button or any other methods.

Best regards
Vilas Desai

Code: Select all

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

[HansV]

You can specify that inserting a row is allowed when you protect the sheet:

S0100.png

If that doesn't help, you'll have to provide a button and/or keyboard shortcut that calls a macro that
- Unprotects the sheet
- Inserts a row
- Protects the sheet

[HansV]

1. You could change the Worksheet_SelectionChange event procedure as follows:

Code: Select all

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = Cells.Address Then
        Beep
        Range("A1").Select
        Exit Sub
    End If
    If Target.CountLarge > 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

2. Disabling undo is tricky. Why do you want that?

[vilas desai]

Dear Hans,
Do you advise me to modify the current code or do you advise me to add this piece of code which you gave me. Either way, I request you to make this change in the code that I have provided because as you know, its become very complicated and any mistake that I could perhaps do will cause problems difficult for me to resolve.

Best regards
Vilas Desai

[HansV]

The code that I posted is a replacement for the Worksheet_SelectionChange event procedure.

[vilas desai]

Dear Hans,
Thank you for your courteous suggestion. deleti
In line with my opening note, I am looking for a solution to insert a New row , but DISALLOW deleting a row by right clicking on the row bar and choosing "Delete"
My current code does not allow row delete but also does not allow row insert.
With your code, I can Insert but I can also delete which is not required.
Please advise
Regards
Vilas DEsai

[HansV]

See the screenshot a few replies up in this thread. If you do not tick the check box "Delete rows", users will not be able to delete a row in a protected sheet.

[vilas desai]

OK, Hans, Let me please correct my mistake in communication. When I said "Protected Sheet" what I mean is protected by a code where I disallow the 'delete' method by right click on rows and choosing the 'delete' action. So, PROTECTED here, does not refer to the conventional Review --> Protect worksheet.
The current code allows delete action only when the user hits the hard 'delete' key on the keyboard followed by right click on the Row bar and choosing the 'Delete" option.
So, the users can delete a row only by first delete'ing col D with hard key on keyboard. And I want to retain only this method of deleting.With the code that your have provided me, I can insert a row but I can also use the right selections of rows followed by choosing "Delete" key, which is what I want to avoid. I hope this correction in explanation can better explain the situation

Best regards and thanks in advance
Best regards
Vilas Desai

[HansV]

I fear that's too complicated (for me).

[vilas desai]

No problems Hans. Nevertheless your efforts is highly appreciated and thanks a lot for that. Best wishes and regards.

[vilas desai]

Dear Hans,

Please see my request on 28 sept , 2 trails above this one. I have a question: Can we achieve this (insert a new row by right click on row and the choose insert row) by first stopping the macro, then insert the row and then run the macro again.

Please advise.
tanks in advance and with best regards
Vilas Desai

[Rudi]

Hi Vilas,

Hans is traveling currently and will only be back in a few days.
A simple 2 cents answer to your question is as follows:

You can interrupt a macro, in the traditional sense, by using a message box or and input box or a custom user form, gather information via these forms/boxes, and then continue the macro by the user clicking a command button like OK or Cancel. It is not an effective and logical procedure to stop a macro and allow the user to do actions directly on the spreadsheet and then have the macro continue. To do this, you would need events, but it will be tricky and illogical to do it this way. In your example, if you want the macro to stop and allow for adding/deleting rows, it is recommended to use an input box or user form to gather the info (which rows to act on) and then have the macro continue based on the users input.

Hope that clarifies your question.

[vilas desai]

Thanks, Rudi
How can I send you the actual file so that you can immediately get the trick and help me with the placement of the code.
The file is large and cannot be reduced to less than 250kb
Best regards
Vilas Desai

[Rudi]

I sent you my email in a PM.