VBA to swap cell values, but enter the swapped value in cell below.

[MeaclH]

Hi all,
I need some help please with a VBA that has been running successfully for some time, however need to tweak slightly.
Below is the code. Essentially it swaps the 2 selected cell ranges. This is great, however, I need it to function slightly different.
I need to keep the data in each original cell ranges, but copy it to the cell 2 below the target ranges and vice versa
I'd then like the original cells to be formatted with a strikethrough.

Any help would be much appreciated.

Cheers,
Hayden

Photos below for before and after

Sub swap()
       Dim sCmt As String
    Dim rCell As Range

    sCmt = InputBox( _
      Prompt:="Enter Comment to Add" & vbCrLf & _
      "Comment will be added to all cells in Selection", _
      Title:="Comment to Add")
    If sCmt = "" Then
        MsgBox "No comment added"
    Else
        For Each rCell In Selection
            With rCell
                .ClearComments
                .AddComment
                .Comment.Text Text:=sCmt
            End With
        Next
    End If
    Set rCell = Nothing
    
    If Selection.Areas.Count <> 2 Then Exit Sub

    Set range1 = Selection.Areas(1)
    Set range2 = Selection.Areas(2)

    If range1.Rows.Count <> range2.Rows.Count Or _
        range1.Columns.Count <> range2.Columns.Count Then Exit Sub
   

    range1Address = range1.Address
    range1.Cut
    range2.Insert shift:=xlShiftToRight
    Range(range1Address).Delete shift:=xlToLeft
    
    range2Address = range2.Address
    range2.Cut
    Range(range1Address).Insert shift:=xlShiftToRight
    Range(range2Address).Delete shift:=xlToLeft
        
End Sub

 

[myall_blues]

Also @myall_blues, one thing I realised after testing your code was that it works perfectly when selecting 2 or more cells in each target range, but when I only select 1 cell in each range to swap it responds with a Type Mismatch error. Not sure if you can suggest a tweak?
Happy Friday!
Hayden

Hi Hayden

This should fix it.

Sub swaptosameplace()
    Dim sCmt As String
    Dim i As Long
    Dim rCell As Range
    Dim area1 As Variant, area2 As Variant, swapval As Variant
    
    sCmt = InputBox( _
      Prompt:="Enter Comment to Add" & vbCrLf & _
      "Comment will be added to all cells in Selection", _
      Title:="Comment to Add")
    If sCmt = "" Then
        MsgBox "No comment added"
    Else
        For Each rCell In Selection
            With rCell
                .ClearComments
                .AddComment
                .Comment.Text Text:=sCmt
            End With
        Next
    End If
    Set rCell = Nothing
    If Selection.Areas.Count <> 2 Then Exit Sub
    If Selection.Areas(1).Columns.Count <> Selection.Areas(2).Columns.Count Then
        MsgBox ("Selection areas must have the same number of columns")
        Exit Sub
    End If
    area1 = Selection.Areas(1)
    area2 = Selection.Areas(2)
    If Selection.Areas(1).Columns.Count = 1 Then
        swapval = area1
        area1 = area2
        area2 = swapval
    Else
        For i = LBound(area1, 2) To UBound(area1, 2)
            swapval = area1(1, i)
            area1(1, i) = area2(1, i)
            area2(1, i) = swapval
        Next
    End If
    Selection.Areas(1) = area1
    Selection.Areas(2) = area2
    
    Selection.Areas(1).Font.Strikethrough = True
    Selection.Areas(2).Font.Strikethrough = True
End Sub