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

 

[MeaclH]

G'day @myall_blues,
Hoping for your help again. Looking to tweak this VBA code again. Want it to function as per my first attempt, where 2 sets of selected cells swap upon running of the macro, and request for a comment to be added.
This is different than your original great solution, where I want the cells to be swapped directly rather than placed in a cell below.

Thanks again for your help.

Hayden

 

[myall_blues]

Hi
For future reference it's best to start a new thread once a question has been marked as answered, because most of the experts here don't bother looking at those and so your net won't be cast very wide.
Ignoring the other cells, do I understand correctly you now want to go from this:

to this?

If yes then this should work. I wasn't sure what you wanted to do about formatting this time.

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
    area1 = Selection.Areas(1)
    area2 = Selection.Areas(2)
    For i = LBound(area1, 2) To UBound(area1, 2)
        swapval = area1(1, i)
        area1(1, i) = area2(1, i)
        area2(1, i) = swapval
    Next
    Selection.Areas(1) = area1
    Selection.Areas(2) = area2
    
    Selection.Areas(1).Font.Strikethrough = True
    Selection.Areas(2).Font.Strikethrough = True
End Sub

 

[MeaclH]

Hi
For future reference it's best to start a new thread once a question has been marked as answered, because most of the experts here don't bother looking at those and so your net won't be cast very wide.
Ignoring the other cells, do I understand correctly you now want to go from this:
View attachment 115778

to this?

View attachment 115779

If yes then this should work. I wasn't sure what you wanted to do about formatting this time.

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
    area1 = Selection.Areas(1)
    area2 = Selection.Areas(2)
    For i = LBound(area1, 2) To UBound(area1, 2)
        swapval = area1(1, i)
        area1(1, i) = area2(1, i)
        area2(1, i) = swapval
    Next
    Selection.Areas(1) = area1
    Selection.Areas(2) = area2
   
    Selection.Areas(1).Font.Strikethrough = True
    Selection.Areas(2).Font.Strikethrough = True
End Sub

Murray, legend again. Thanks for the tip and taking the time to respond.
Not sure if its possible, but regarding the comment that is added. For instance, say the macro is run once on a certain cell, the comment is added all well and good. Say the macro is run again on the same cell at a later time, the comment is over written. Is there a way to add to the comment rather than completely wiping the previous comment?

Thanks again mate,
Hayden

 

[myall_blues]

Not sure if its possible, but regarding the comment that is added. For instance, say the macro is run once on a certain cell, the comment is added all well and good. Say the macro is run again on the same cell at a later time, the comment is over written. Is there a way to add to the comment rather than completely wiping the previous comment?

Allegedly there is, but I can't work it out. According to the documentation the Text method has three parameters, and providing the second and third should not overwrite existing text. But I've attempted various combinations like .Comment.Text sCmt,20, FALSE all without success. It overwrites every time.
Probably another question for the big boys!

Best wishes

 

[MeaclH]

Allegedly there is, but I can't work it out. According to the documentation the Text method has three parameters, and providing the second and third should not overwrite existing text. But I've attempted various combinations like .Comment.Text sCmt,20, FALSE all without success. It overwrites every time.
Probably another question for the big boys!

Best wishes

Thanks legend.
I had this sheet code provided to me for another problem I had, which seems to function correctly for adding a comment and not overwriting.
Not sure how to modify it for the code you provided for this solution, but FYI if you figure it out for future use.
Cheers mate,
Hayden

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Resp As String
  
  If Target.CountLarge = 1 And Not Intersect(Target, Range("CG9: T9 , G14: T14 , G19: T19 , G24: T24 , G29: T9 , G34: T34 , G39: T39 , G44: T44 , G49: T49 , G54: T54 , G59: T59 , G64: T64 , G69: T69 , G74: T74 , G79: T79 , G84: T84 , G89: T89 , G94: T94 , G99: T99 , G104: T104")) Is Nothing Then
    With Target
      Select Case .Value
        Case "SDO", "STFN", "CDO", "CTFN" '<- Add more trigger values here if required
          Resp = Application.InputBox("Please insert details of absenteeism", _
          Title:="Absenteeism Details")
          If Len(Resp) > 0 And Resp <> "False" Then
            If Not .Comment Is Nothing Then
              .Comment.Text .Comment.Text & vbLf & Resp
            Else
              .AddComment Text:=Resp
            End If
          End If
      End Select
    End With
  End If
End Sub

 

[MeaclH]

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