VBA: Allow Overwriting of data, prevent deletion

[jamescooper]

Hello,

Is the above possible in VBA code for a sheet?

So allow data to be overwritten but not deleted?

Many thanks.

 

[steve the fish]

Depends what you mean by delete. If by delete you mean clear the cell than thats not possible as far as im aware. However you can stop the cell being deleted, that is right click and delete, but still allow it to be edited. Highlight the cell/s in question, right click and format cells. On the protection tab uncheck locked. Close the dialog box. Go to review tab and then protect the sheet.

 

[jamescooper]

Depends what you mean by delete. If by delete you mean clear the cell than thats not possible as far as im aware. However you can stop the cell being deleted, that is right click and delete, but still allow it to be edited. Highlight the cell/s in question, right click and format cells. On the protection tab uncheck locked. Close the dialog box. Go to review tab and then protect the sheet.

This code prevents deletion, however, I would like to allow pasteover

Private Sub Worksheet_Change(ByVal Target As Range)


    If Intersect(Target, Range("A1:AK1000000")) Is Nothing Then Exit Sub
    On Error GoTo ExitPoint
    Application.EnableEvents = False
    If Not IsDate(Target(1)) Then
        Application.Undo
        MsgBox " You can't delete cell contents from this range " _
        , vbCritical, "Kutools for Excel"
    End If
ExitPoint:
    Application.EnableEvents = True


End Sub

 

[Stiuart_W]

Actually what your code does is undo any entry that is NOT a date

 

[jkpieterse]

Sure. Right-click the sheet tab and select "View code". Then in the code window paste this:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vPrev As Variant
    Dim vNew As Variant
    Dim lRow As Long
    Dim lCol As Long
    Dim bMsgGiven As Boolean
    Application.EnableEvents = False
    vNew = Target.Formula
    Application.Undo
    vPrev = Target.Formula
    Application.EnableEvents = True
    If IsArray(vPrev) Then
        For lRow = LBound(vPrev, 1) To UBound(vPrev, 1)
            For lCol = LBound(vPrev, 2) To UBound(vPrev, 2)
                If Len(vNew(lRow, lCol)) = 0 And Len(vPrev(lRow, lCol)) > 0 Then
                    If Not bMsgGiven Then
                        'only display this message once
                        MsgBox "Deleting content on this worksheet is not allowed!", vbExclamation
                        bMsgGiven = True
                    End If
                    'restore previous formula
                    vNew(lRow, lCol) = vPrev(lRow, lCol)
                End If
            Next
        Next
        'Restore all formulas now
        'prevent this routine to cause a call to itself
        Application.EnableEvents = False
        Target.Formula = vNew
        Application.EnableEvents = True
    Else
        If Len(vNew) = 0 And Len(vPrev) > 0 Then
            MsgBox "Deleting content on this worksheet is not allowed!", vbExclamation
            'Something was deleted, restore all formulas now
            'prevent this routine to cause a call to itself
            Application.EnableEvents = False
            Target.Formula = vPrev
            Application.EnableEvents = True
        Else
            Application.EnableEvents = False
            Target.Formula = vNew
            Application.EnableEvents = True
        End If
    End If
End Sub

Please note that this will mean the undo function will stop to work for this worksheet.

 

[jamescooper]

Sure. Right-click the sheet tab and select "View code". Then in the code window paste this:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vPrev As Variant
    Dim vNew As Variant
    Dim lRow As Long
    Dim lCol As Long
    Dim bMsgGiven As Boolean
    Application.EnableEvents = False
    vNew = Target.Formula
    Application.Undo
    vPrev = Target.Formula
    Application.EnableEvents = True
    If IsArray(vPrev) Then
        For lRow = LBound(vPrev, 1) To UBound(vPrev, 1)
            For lCol = LBound(vPrev, 2) To UBound(vPrev, 2)
                If Len(vNew(lRow, lCol)) = 0 And Len(vPrev(lRow, lCol)) > 0 Then
                    If Not bMsgGiven Then
                        'only display this message once
                        MsgBox "Deleting content on this worksheet is not allowed!", vbExclamation
                        bMsgGiven = True
                    End If
                    'restore previous formula
                    vNew(lRow, lCol) = vPrev(lRow, lCol)
                End If
            Next
        Next
        'Restore all formulas now
        'prevent this routine to cause a call to itself
        Application.EnableEvents = False
        Target.Formula = vNew
        Application.EnableEvents = True
    Else
        If Len(vNew) = 0 And Len(vPrev) > 0 Then
            MsgBox "Deleting content on this worksheet is not allowed!", vbExclamation
            'Something was deleted, restore all formulas now
            'prevent this routine to cause a call to itself
            Application.EnableEvents = False
            Target.Formula = vPrev
            Application.EnableEvents = True
        Else
            Application.EnableEvents = False
            Target.Formula = vNew
            Application.EnableEvents = True
        End If
    End If
End Sub

Please note that this will mean the undo function will stop to work for this worksheet.

Thanks - this still allows me to overwrite rows - which is good. But it still allows me to go into the sheet and delete cells/records?

Any ideas?

 

[jkpieterse]

You didn't mention that. I guess you'll have to combine this code with protecting the worksheet and unlocking cells.