is there a way to make this code shorter / excel worksheet change-CodePudding

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = Worksheets("sheet1").Range("a1").Address Then
       Worksheets("sheet2").Range("a1") = Worksheets("sheet2").Range("a1")   Worksheets("sheet1").Range("a1")
        Worksheets("sheet1").Range("a1").ClearContents
    End If
    If Target.Address = Worksheets("sheet1").Range("a2").Address Then
       Worksheets("sheet2").Range("a2") = Worksheets("sheet2").Range("a2")   Worksheets("sheet1").Range("a2")
        Worksheets("sheet1").Range("a2").ClearContents
    End If
    If Target.Address = Worksheets("sheet1").Range("b1").Address Then
       Worksheets("sheet2").Range("b1") = Worksheets("sheet2").Range("b1")   Worksheets("sheet1").Range("b1")
        Worksheets("sheet1").Range("b1").ClearContents
    End If
    If Target.Address = Worksheets("sheet1").Range("b2").Address Then
       Worksheets("sheet2").Range("b2") = Worksheets("sheet2").Range("b2")   Worksheets("sheet1").Range("b2")
        Worksheets("sheet1").Range("b2").ClearContents
    End If
    If Target.Address = Worksheets("sheet1").Range("c1").Address Then
       Worksheets("sheet2").Range("c1") = Worksheets("sheet2").Range("c1")   Worksheets("sheet1").Range("c1")
        Worksheets("sheet1").Range("c1").ClearContents
    End If
    If Target.Address = Worksheets("sheet1").Range("c2").Address Then
       Worksheets("sheet2").Range("c2") = Worksheets("sheet2").Range("c2")   Worksheets("sheet1").Range("c2")
        Worksheets("sheet1").Range("c2").ClearContents
    End If
    Application.EnableEvents = True
End Sub

CodePudding user response：

simplify the code by utilizing the cell references built into vba.

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim a As Variant
    Application.EnableEvents = False
        a = Target.Address
        Select Case a
                Case "$A$1", "$A$2", "$B$1", "$B$2", "$C$1", "$C$2"
                        With Worksheets("sheet2")
                                .Range(a) = .Range(a)   Worksheets("sheet1").Range(a)
                        End With
                        Worksheets("sheet1").Range(a).Clear
                Case Else
        End Select
    Application.EnableEvents = True
End Sub

CodePudding user response：

Worksheet Change on Multiple Cells

It is assumed that the following code is located in the (sheet) module of worksheet Sheet1 (Me).

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' c - Criteria - tested
' s - Source - read from
' d - Destination - written to

    ' Restrict to run only if a change happens in the criteria range.
    Dim crg As Range: Set crg = Range("A1:C2")
    Dim srg As Range: Set srg = Intersect(crg, Target)
    If srg Is Nothing Then Exit Sub

    ' Note that 'Me.Parent = ThisWorkbook'.
    Dim dws As Worksheet: Set dws = Me.Parent.Worksheets("Sheet2")
    
    ' Don't allow triggering another event while this one is running.
    Application.EnableEvents = False
    ' Don't allow to exit the procedure without enabling events.
    ' Study the flow of the error-handling routine.
    On Error GoTo ClearError

    Dim sCell As Range
    Dim sValue As Variant
    Dim dCell As Range
    Dim dValue As Variant

    ' Cover multiple cell changes.
    For Each sCell In srg.Cells
        sValue = sCell.Value
        If IsNumeric(sValue) Then
            Set dCell = dws.Range(sCell.Address)
            dValue = dCell.Value
            If IsNumeric(dValue) Then
                dCell.Value = dValue   sValue
            'Else 'dValue not numeric
            End If
        'Else ' sValue not numeric
        End If
    Next sCell
    srg.ClearContents ' clear the contents of the cell(s) in one go

SafeExit:
    Application.EnableEvents = True
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub