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]

Is this what you wanted?

Option Explicit

Sub swap()
    Dim sCmt As String
    Dim rCell As Range, range1 As Range, range2 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
    range1.Copy range2.Offset(2)
    range2.Copy range1.Offset(2)
    range1.Font.Strikethrough = True
    range2.Font.Strikethrough = True
End Sub

 

[MeaclH]

Is this what you wanted?

Option Explicit

Sub swap()
    Dim sCmt As String
    Dim rCell As Range, range1 As Range, range2 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
    range1.Copy range2.Offset(2)
    range2.Copy range1.Offset(2)
    range1.Font.Strikethrough = True
    range2.Font.Strikethrough = True
End Sub

Murray, you're a legend. Thanks mate. Works perfectly. One thing, which was an issue with the original I posted; how can I have only the cell values copy and pasted, not the formatting as well? Any ideas?

Thanks heaps!

 

[myall_blues]

You're welcome - I'm glad it worked.

To fix the format issue, change these two lines:

    range1.Copy range2.Offset(2)
    range2.Copy range1.Offset(2)

to this:

    range2.Offset(2) = range1.Value
    range1.Offset(2) = range2.Value