Paste sum of range to another cell

user_8212903 0
Viewed 208

I'm trying to work on a code which copies a range's address to the clipboard and when I paste it, it pastes the sum of the copied range. Below code works when I'm copying and pasting my range to same worksheet. It also works when I'm copying and pasting my range to a different worksheet of same workbook as long as my range is in sequence.

BUT, if my range is for example A1,A3 i.e. I want to sum cell A1 & A3 ignoring cell A2, then my code only works in same worksheet. If I try to copy and paste a non-sequential range to a different worksheet, my result is =+SUM(Sheet1!A1,A3) and I want my result to be =+SUM(Sheet1!A1,Sheet1!A3).

Here's my partially working code:

Sub CopySum()
    Dim ObjData As New DataObject
    ObjData.Clear
    ObjData.SetText "+sum('" & Selection.Parent.Name & "'!" & Selection.Address(0, 0) & ")"
    ObjData.PutInClipboard
End Sub

Please let me know what changes should I make to get the desired result.

excel-formula vba excel
4 Answers

If you want to change =+SUM(Sheet1!A1,A3) into =+SUM(Sheet1!A1,Sheet1!A3) you just need to replace all , with ,Sheet1!. So your code needs to be

ObjData.SetText "+sum('" & Selection.Parent.Name & "'!" & Replace$(Selection.Address(0, 0), ",", ",'" & Selection.Parent.Name & "'!") & ")"

Actually I thought

Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False, External:=True)

should also return Sheet1!A1,Sheet1!A3 due to External:=True but obviously ther is a bug and it returns Sheet1!A1,A3 which is obviously not what one would expect (as it doesn't make any sense that the address method returns only the first one as external).

user_32196130

The Hard Way

The Flow

  • Checks if Selection is a range.
  • Defines the range address (inferior to Pᴇʜ's accepted answer).
  • Determines list separator if more than one range area.
  • Copies to clipboard using late binding.

The Code

Option Explicit

Sub CopySum()
    ' Define constants.
    Const Lead As String = "+SUM("
    Const Trail As String = ")"
    ' Validate selection.
    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If
    ' Declare variables.
    Dim rng As Range
    Dim Data() As Variant
    Dim n As Long
    ' Define range address.
    For Each rng In Selection.Areas
        n = n + 1
        ReDim Preserve Data(1 To n)
        Data(n) = "'" & rng.Parent.Name & "'!" & rng.Address(0, 0)
    Next rng
    ' Determine list separator.
    Dim sep As String
    If n > 1 Then
        sep = Application.International(xlListSeparator)
    End If
    ' Copy to clipboard.
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .Clear
        .SetText Lead & Join(Data, sep) & Trail
        .PutInClipboard
    End With
End Sub
user_98140690

Modified your code a little bit so that it works on different workbooks as well.

Option Explicit

Sub CopySum()
    ' Define constants.
    Const Lead As String = "+SUM("
    Const Trail As String = ")"
    ' Validate selection.
    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If
    ' Declare variables.
    Dim rng As Range
    Dim Data() As Variant
    Dim n As Long
    ' Define range address.
    For Each rng In Selection.Areas
        n = n + 1
        ReDim Preserve Data(1 To n)
        Data(n) = rng.Address(External:=True)
    Next rng
    ' Determine list separator.
    Dim sep As String
    If n > 1 Then
        sep = Application.International(xlListSeparator)
    End If
    ' Copy to clipboard.
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .Clear
        .SetText Lead & Join(Data, sep) & Trail
        .PutInClipboard
    End With
End Sub
user_82129030

I think this is what I'm going to stick with.

Sub CopyPaste_Sum_Link_My_Version()
  Dim ObjData As New DataObject
  Dim prefix As String
  prefix = ActiveWorkbook.Name
  ObjData.Clear
  ObjData.SetText "+sum(" & Replace$(Selection.Address(External:=True), ",", ",'[" & prefix & "]" & Selection.Parent.Name & "'!") & ")"
  ObjData.PutInClipboard
End Sub
user_82129030
Related