Get All Possible Sums From List of Numbers

[mswoods1]

I have a list and need to get all possible sums of two numbers from the list.

Example:

List: 1, 2, 3
Return: 3, 4, 5

The list of numbers is contained in a range within an Excel workbook.

The output needs to be outputted to a different range.

 

[craig.penny]

Run this code:

Sub Combinations()
Dim Rng1 As Range, oCell As Range
Dim Count1 As Long, i As Long, j As Long, k As Long
Dim R1C As Long
Dim Mat1() As Double
Dim Mat1A() As Variant
Set Rng1 = Application.InputBox(prompt:="Select Input Range", Default:=ActiveCell, Type:=8)
Count1 = Rng1.Cells.Count
k = 0
For i = 1 To Count1
      For j = 1 To (Count1 - i)
            k = k + 1
      Next j
Next i
ReDim Mat1(1 To Count1) As Double
ReDim Mat1A(1 To k) As Variant
R1C = 0
For Each oCell In Rng1.Cells
      R1C = R1C + 1
      Mat1(R1C) = oCell.Value
Next oCell
k = 1
For i = 1 To Count1
      For j = i + 1 To Count1
            Mat1A(k) = Mat1(i) + Mat1(j)
            k = k + 1
      Next j
Next i
For i = 1 To UBound(Mat1A, 1)
      Cells(i, 1) = Mat1A(i)
Next i
  
End Sub

After it runs, Mat1A() will have all the combinations of two numbers with no repeats. The outcome will be displayed in the first column.

Let me know if it works for you

 

[hiker95]

craig.penny,

Nice....

This is going into my archives.

Thanks.

Have a great day,
hiker95

 

[mswoods1]

Hi craig.penny,

Thanks for the solution. Your version doesn't work for me exactly. I still get some duplicate values (for example, if I test it with the inputs 1,2,3,4,5). However, with a bit of mods I can get it to work. I added a collection and then added the numbers to the collection to get unique values (since collections will only hold unique values.) Below is a modified version of your code.

Cheers.

Sub Combinations()
Dim Rng1 As Range, oCell As Range
Dim Count1 As Long, i As Long, j As Long, k As Long
Dim R1C As Long
Dim Mat1() As Double
Dim Mat1A() As Variant
Set Rng1 = Application.InputBox(prompt:="Select Input Range", Default:=ActiveCell, Type:=8)
Count1 = Rng1.Cells.Count
k = 0
For i = 1 To Count1
      For j = 1 To (Count1 - i)
            k = k + 1
      Next j
Next i
ReDim Mat1(1 To Count1) As Double
ReDim Mat1A(1 To k) As Variant
R1C = 0
For Each oCell In Rng1.Cells
      R1C = R1C + 1
      Mat1(R1C) = oCell.Value
Next oCell
k = 1
For i = 1 To Count1
      For j = i + 1 To Count1
            Mat1A(k) = Mat1(i) + Mat1(j)
            k = k + 1
      Next j
Next i

Dim UniqColl As Collection
Set UniqColl = New Collection

On Error Resume Next
For i = 1 To UBound(Mat1A, 1)
    UniqColl.Add CDbl(Mat1A(i)), CStr(Mat1A(i))
Next i
Err.Clear
On Error GoTo 0

For i = 1 To UniqColl.Count
      Cells(i, 1) = UniqColl.Item(i)
Next i
  
End Sub

 

[hiker95]

mswoods1

Nicely done.

This is also going into my archives.

Thanks.

Have a great day,
hiker95

 

[craig.penny]

Hiker95,

I took that code out of a larger routine that checks every possible combination of two ranges. If you found that shorter version useful you might like this one too. I use it when I have large sheets of budget material coming from two different sources. Different departments have different ways of tracking things so one might record 2 items at x total dollars but the other department records it as 5 items at x total dollars. They use different descriptions of the items so I could easily blow a day trying to figure it out manually!

Sub CompareArrays()

On Error GoTo veryEnd

Dim Rng1 As Range
Dim rng2 As Range
Dim Count1 As Long
Dim Count2 As Long
Dim tB1 As Boolean
Dim tB2 As Boolean

Dim ComTex1 As String
Dim ComTex2 As String

Dim s1 As String

Dim oCell As Range
Dim Counter As Long

Dim RunV1 As Double
Dim RunV2 As Double

Dim i As Long
Dim j As Long

Dim R1C As Long
Dim R2C As Long
R1C = 0
R2C = 0

Dim Tolerance As Double
Tolerance = 0.1

Dim Mat1() As Double
Dim Mat2() As Double
Dim Mat1A() As Variant
Dim Mat2B() As Variant

Dim RM1() As Range
Dim RM2() As Range

On Error GoTo veryEnd
Set Rng1 = Application.InputBox(prompt:="select first range", Default:=ActiveCell, Type:=8)
Set rng2 = Application.InputBox(prompt:="select second range", Default:=ActiveCell, Type:=8)
On Error GoTo 0

Count1 = Rng1.Cells.Count
Count2 = rng2.Cells.Count

ReDim Mat1(1 To Count1) As Double
ReDim Mat2(1 To Count2) As Double

ReDim RM1(1 To Count1) As Range
ReDim RM2(1 To Count2) As Range

ReDim Mat1A(1 To 2 ^ Count1 - 1, 0 To 1) As Variant
ReDim Mat2B(1 To 2 ^ Count2 - 1, 0 To 1) As Variant

For Each oCell In Rng1.Cells
  R1C = R1C + 1
  Mat1(R1C) = oCell.Value
  If oCell.Comment Is Nothing Then oCell.AddComment
  oCell.Comment.Text Text:="""Range 1, Cell " & R1C & """" & Chr(10)
  Set RM1(R1C) = oCell
Next oCell

For Each oCell In rng2.Cells
  R2C = R2C + 1
  Mat2(R2C) = oCell.Value
  If oCell.Comment Is Nothing Then oCell.AddComment
  oCell.Comment.Text Text:="""Range 2, Cell " & R2C & """" & Chr(10)
  Set RM2(R2C) = oCell
Next oCell

m = 1
For i = 1 To Count1
  k = 0
  For j = 1 To i
    k = k + 2 ^ (j - 1)
  Next j
  For p = m To k
    If p = k Then
      Mat1A(p, 0) = Mat1(i)
      Mat1A(p, 1) = CStr(i)
    Else
      Mat1A(p, 0) = Mat1A(p - m + 1, 0) + Mat1(i)
      Mat1A(p, 1) = Mat1A(p - m + 1, 1) & "," & CStr(i)
    End If
  Next p
m = k + 1
Next i
  
m = 1
For i = 1 To Count2
  k = 0
  For j = 1 To i
    k = k + 2 ^ (j - 1)
  Next j
  For p = m To k
    If p = k Then
      Mat2B(p, 0) = Mat2(i)
      Mat2B(p, 1) = CStr(i)
    Else
      Mat2B(p, 0) = Mat2B(p - m + 1, 0) + Mat2(i)
      Mat2B(p, 1) = Mat2B(p - m + 1, 1) & "," & CStr(i)
    End If
  Next p
m = k + 1
Next i

For i = 1 To 2 ^ Count1 - 1
  For j = 1 To 2 ^ Count2 - 1
    If Mat1A(i, 0) = Mat2B(j, 0) Then
      ComTex1 = Mat1A(i, 1)
      ComTex2 = Mat2B(j, 1)
'~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
      s1 = ""
      tB1 = False
      For k = 1 To Len(Mat1A(i, 1))
        If Mid(Mat1A(i, 1), k, 1) = "," Then
          RM1(CLng(s1)).Interior.Color = 49407
          
          ComTex1 = RM1(CLng(s1)).Comment.Text & Chr(10) & "R1: " & Mat1A(i, 1) & Chr(10) & _
            "R2: " & Mat2B(j, 1)

          RM1(CLng(s1)).Comment.Text Text:=ComTex1
          RM1(CLng(s1)).Comment.Shape.TextFrame.AutoSize = True
          s1 = ""
        Else
          s1 = s1 & Mid(Mat1A(i, 1), k, 1)
        End If
      Next k
'~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
      RM1(CLng(s1)).Interior.Color = 49407
      
      ComTex1 = RM1(CLng(s1)).Comment.Text & Chr(10) & "R1: " & Mat1A(i, 1) & Chr(10) & _
        "R2: " & Mat2B(j, 1)

      RM1(CLng(s1)).Comment.Text Text:=ComTex1
      RM1(CLng(s1)).Comment.Shape.TextFrame.AutoSize = True
'~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
      s1 = ""
      For k = 1 To Len(Mat2B(j, 1))
        If Mid(Mat2B(j, 1), k, 1) = "," Then
          RM2(CLng(s1)).Interior.Color = 49407

          ComTex2 = RM2(CLng(s1)).Comment.Text & Chr(10) & "R2: " & Mat2B(j, 1) & Chr(10) & _
            "R1: " & Mat1A(i, 1)

          RM2(CLng(s1)).Comment.Text Text:=ComTex2
          RM2(CLng(s1)).Comment.Shape.TextFrame.AutoSize = True
          s1 = ""
        Else
          s1 = s1 & Mid(Mat2B(j, 1), k, 1)
        End If
      Next k
'~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
      RM2(CLng(s1)).Interior.Color = 49407

      ComTex2 = RM2(CLng(s1)).Comment.Text & Chr(10) & "R2: " & Mat2B(j, 1) & Chr(10) & _
        "R1: " & Mat1A(i, 1)

      RM2(CLng(s1)).Comment.Text Text:=ComTex2
      RM2(CLng(s1)).Comment.Shape.TextFrame.AutoSize = True
'~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
    End If
  Next j
  Application.StatusBar = Format(i / ((2 ^ (Count1) - 1)), "0.0%")
Next i
Application.StatusBar = ""
veryEnd:
End Sub

Hopefully someone gets use out of it

 

[hiker95]

craig.penny,

Thanks again.

I will examine the code.

Have a great day,
hiker95