Search code examples
excelvba

ClearContents with Worksheet_Change when multiple cells are selected

I autopopulate a cell in column CD when a cell in column A is filled.

When emptied the value in CD should also be empty.
When deleting one by one it works, but if you select multiple cells in A, for example A14:A16 and delete, the value in CD is not removed.

Private Sub Worksheet_Change(ByVal Target As Range)
    'auto populate cell CD dropshipment naar No als er een cell in kolom A na rij 13 is gevuld met een waarde
   With Target                   'get out if the change ...
      If .Row < 14 Then Exit Sub    'is in any row <= the reserve area at the top of my sheet
      Select Case .Column
         Case Cells(1, "A").Column
            If Not IsEmpty(Target) Then
                With .Offset(0, 81)
                    .Value = "No"
                End With
            End If
            If IsEmpty(Target) Then
                With .Offset(0, 81)
                    .ClearContents
                End With
            End If
            Next Value
      End Select
   End With
Solution

  • A Worksheet Change: Populate or Clear Contents

    Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const TGT_FIRST_CELL As String = "A14"
    Const DST_COLUMN As String = "CD"
    Const DST_STRING As String = "No"
    
    Dim trg As Range:
    With Me.Range(TGT_FIRST_CELL)
        Set trg = .Resize(Me.Rows.Count - .Row + 1)
    End With
    
    Dim irg As Range: Set irg = Intersect(trg, Target)
    If irg Is Nothing Then Exit Sub
    
    Dim crg As Range, prg As Range, icell As Range, dcell As Range
    
    For Each icell In irg.Cells
        Set dcell = icell.EntireRow.Columns(DST_COLUMN)
        If IsEmpty(icell.Value) Then
            BuildRange crg, dcell
        Else
            BuildRange prg, dcell
        End If
    Next icell
    
    Application.EnableEvents = False
        If Not crg Is Nothing Then crg.ClearContents
        If Not prg Is Nothing Then prg.Value = DST_STRING
    Application.EnableEvents = True
    
End Sub

Private Sub BuildRange(ByRef builtRange As Range, addedRange As Range)
    If builtRange Is Nothing Then
        Set builtRange = addedRange
    Else
        Set builtRange = Union(builtRange, addedRange)
    End If
End Sub

    EDIT

    • To make it work for multiple cells (see comment below), use the following instead:

    enter image description here

    Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    PopulateOrClearOnChange "A14", "CD", "No", Target
    PopulateOrClearOnChange "X14", "BD", "NL01", Target
    PopulateOrClearOnChange "AB14", "BE", "BE01", Target
    PopulateOrClearOnChange "AF14", "BF", "NL13", Target
End Sub

Private Sub PopulateOrClearOnChange( _
        TargetFirstCellAddress As String, _
        DestinationColumn As String, _
        DestinationString As String, _
        Target As Range)
    
    Dim ws As Worksheet: Set ws = Target.Worksheet
    
    Dim trg As Range:
    With ws.Range(TargetFirstCellAddress)
        Set trg = .Resize(ws.Rows.Count - .Row + 1)
    End With
    
    Dim irg As Range: Set irg = Intersect(trg, Target)
    If irg Is Nothing Then Exit Sub
    
    Dim prg As Range, crg As Range, icell As Range, dcell As Range
    
    For Each icell In irg.Cells
        Set dcell = icell.EntireRow.Columns(DestinationColumn)
        If IsEmpty(icell.Value) Then
            BuildRange crg, dcell
        Else
            BuildRange prg, dcell
        End If
    Next icell
    
    Application.EnableEvents = False
        If Not crg Is Nothing Then crg.ClearContents
        If Not prg Is Nothing Then prg.Value = DestinationString
    Application.EnableEvents = True

End Sub

Private Sub BuildRange(ByRef builtRange As Range, addedRange As Range)
    If builtRange Is Nothing Then
        Set builtRange = addedRange
    Else
        Set builtRange = Union(builtRange, addedRange)
    End If
End Sub