VBA code to clear cell based on another cell being changed-CodePudding

I know how to clear one cell based on another cell being changed.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("K2")) Is Nothing Then
        Range("L2").ClearContents
    End If
End Sub

But I want this to pertain all the way down each column, so if "K3" is changed, I want to clear "L3", but not have "L2" or any other not pertaining to that row change.

Any help is appreciated

Thanks,

CodePudding user response：

Use Offset property.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("K:K")) Is Nothing Then
        target.offset(,1).ClearContents
    End If
End Sub

CodePudding user response：

Try the following.
Target.Offset(0, 1) will clear the cell to the left of the modified cell.

If Not Intersect(Target, Range("K:K")) Is Nothing Then
    Target.Offset(0, 1).ClearContents
End If

If the user modifies more than one cell at once (eg with Copy&Paste), you might want to check every single cell. And as you modify a cell from the same worksheet, you should switch off Event handling while your code is running - else your modification will trigger another call of your Change-Routine

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    On Error Goto Change_Exit
    Dim cell As Range
    
    For Each cell In Target
        If Not Intersect(cell, Range("K:K")) Is Nothing Then
            cell.Offset(0, 1).ClearContents
        End If
    Next

Change_Exit:
    Application.EnableEvents = True
End Sub

CodePudding user response：

A Worksheet Change: ClearContents

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo ClearError ' enable error handling
    
    Const sfcAddress As String = "K2"
    Const dCol As String = "L"
    
    ' Reference the column range (exclude above the first cell (header(s)))
    Dim scrg As Range
    With Range(sfcAddress)
        Set scrg = .Resize(.Worksheet.Rows.Count - .Row   1)
    End With

    ' Reference the intersecting range.
    Dim srg As Range: Set srg = Intersect(scrg, Target)
    If srg Is Nothing Then Exit Sub
    
    Dim drg As Range
    Dim sarg As Range ' copy/pasted multiple areas are only possible via VBA
    
    ' Combine the areas into a range.
    For Each sarg In srg.Areas
        If drg Is Nothing Then Set drg = sarg Else Set drg = Union(drg, sarg)
    Next sarg

    ' 'drg' can't be 'Nothing' since 'srg' is already 'something'.
    'If drg Is Nothing Then Exit Sub
    
     ' Prevent retriggering this or triggering any other event.
    Application.EnableEvents = False
    
    Intersect(drg.EntireRow, Columns(dCol)).ClearContents
        
SafeExit:
    On Error Resume Next ' defer error handling; prevent endless loop if error
        ' Enable events if they were disabled.
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0 ' disable error handling
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub


Sub MultiRangeTest()
    Range("K2:K10,K16:K20").Value = "Test"
End Sub