Automatic swapping of values among cells if a single cell value is changed in Excel-CodePudding

So I've an excel table as

If I change the value of 3 to 1, the value 1 should automatically change to 3. Thus the final table should be like

CodePudding user response：

You could try this code to be put in the worksheet code pane (myAddress set as A1:A4 implies column A row 1 to 4, which needs to be modified according to the user's worksheet)

Option Explicit

Dim myVal As Variant
Dim okChange As Boolean
Const myAddress As String = "A1:A4"

Private Sub Worksheet_Change(ByVal target As Range)

    If Not okChange Then Exit Sub

    Dim f As Range
        Set f = Range(myAddress).Find(what:=target.Value, LookIn:=xlValues, lookat:=xlWhole, after:=target)
        If Not f Is Nothing Then
            Application.EnableEvents = False
            f.Value = myVal
            Application.EnableEvents = True
        End If
        
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    okChange = False
    Select Case True
        Case target.CountLarge > 1    
        Case Intersect(target, Range(myAddress)) Is Nothing    
        Case Else
            myVal = target.Value
            okChange = True    
    End Select
End Sub

CodePudding user response：

In this answer I'm assuming the Table is called Table1 and the column you wish the sub to affect is called Column1. Edit the code to your requirement as necessary.

Private Sub Worksheet_Change(ByVal Target As Range)
'Exit sub if edited value isn't in the desired range:
If Intersect(Target, ActiveSheet.Range("Table1[Column1]")) Is Nothing Then Exit Sub

Dim OldValue As Variant, changeCell as Range

'Find the Old value of the cell
With Application
    .EnableEvents = False
    .Undo
    OldValue = Target.Value
    .Undo
End With 'Application

'Find the value to be changed:
Set ChangeCell = ExceptRange(Range("Table1[Column1]"), Target).Find(What:=Target.Value, LookIn:=xlValues)

'Edit to the Old value
If Not ChangeCell Is Nothing Then ChangeCell.Value = OldValue

Application.EnableEvents = True
End Sub

Function ExceptRange(Rng As Range, Except As Range) As Range
'The opposite of Intersect
Dim a As Long, Confirmed() As Range
For a = 1 To Rng.Cells.Count
    If Intersect(Rng.Cells(a), Except) Is Nothing Then
        If ExceptRange Is Nothing Then
            Set ExceptRange = Rng.Cells(a)
        Else
            Set ExceptRange = Union(ExceptRange, Rng.Cells(a))
        End If
    End If
Next
End Function