VBA to find combination of values to target sum

Oakwoodbespoke

New Member
Joined
Jun 27, 2023
Messages
23
Office Version
  1. 365
Platform
  1. Windows
Hi,

I am working on a VBA that I found on the web, where I have a list of values (Money, Accounting) and I have a target value, i want it to be able to find the combination of values in the list to add up to the target value.

Basically they are invoice values, and I want to find the invoices values that add up to a value that has been taken from our business account.

I have the following but it only works with whole numbers ie £3,450.00, as soon as i have one that is say £4,567.45 its doesn't work.

I'm guessing it something to do with Integer

current code (it also has a user form for input)

Main Code


VBA Code:
Public RefArray1 As String
Public DS As Variant
Public TargetSum As integer
Public TargetCol As Integer
Public TargetRow As Integer


Sub FindAllCombinations()

UserForm1.Show

End Sub

Function GrayCode(Items As Variant) As String
    Dim CodeVector() As Integer
    Dim i, kk, rr, col1, row1, n1, e As Integer
    Dim lower As Integer, upper As Integer
    Dim SubList As String
    Dim NewSub As String
    Dim done As Boolean
    Dim OddStep As Boolean
    Dim SSS
    Dim TargetArray() As String

    kk = TargetCol
    rr = TargetRow
    col1 = TargetCol + 3
    row1 = TargetRow
    OddStep = True
    lower = LBound(Items)
    upper = UBound(Items)
    Cells(rr - 1, kk) = "Result"
    Cells(rr - 1, kk + 1) = "Sum"
    Cells(rr, kk + 1) = TargetSum
    Cells(rr - 1, kk).Font.Bold = True
    Cells(rr - 1, kk + 1).Font.Bold = True
    ReDim CodeVector(lower To upper) 'it starts all 0
    Do Until done

        NewSub = ""
        For i = lower To upper
            If CodeVector(i) = 1 Then
                If NewSub = "" Then
                    NewSub = "," & Items(i)
                    SSS = SSS + Items(i)
                Else
                    NewSub = NewSub & "," & Items(i)
                    SSS = SSS + Items(i)
                End If
            End If
        Next i
            
        If NewSub = "" Then NewSub = "{}" 'empty set
            SubList = SubList & vbCrLf & NewSub
            If SSS = TargetSum Then
            Cells(rr, kk).NumberFormat = "@"
            Cells(rr, kk) = "{ " & Mid(NewSub, 2) & " }"
            TargetArray() = Split(Mid(NewSub, 2), ",")
            n1 = UBound(TargetArray)
            For e = 0 To n1
            Cells(row1, col1) = TargetArray(e)
            row1 = row1 + 1
            Next e
            col1 = col1 + 1
            row1 = TargetRow
            rr = rr + 1
        End If
        SSS = 0
        'now update code vector
        If OddStep Then
            'just flip first bit
            CodeVector(lower) = 1 - CodeVector(lower)
        Else
            'first locate first 1
            i = lower
            Do While CodeVector(i) <> 1
                i = i + 1
            Loop
            'done if i = upper:
            If i = upper Then
                done = True
            Else
                'if not done then flip the *next* bit:
                i = i + 1
                CodeVector(i) = 1 - CodeVector(i)
            End If
        End If
        OddStep = Not OddStep 'toggles between even and odd steps
    Loop
    GrayCode = SubList
End Function


Code for user input


VBA Code:
Private Sub CommandButton1_Click()
Dim B
Dim c As Integer
Dim d As Integer
Dim A() As Variant
Dim i As Integer
Dim e As Integer
DS = Range(RefEdit1)
TargetSum = TextBox1.Value

Range(RefEdit2).Select
TargetCol = Selection.Column
TargetRow = Selection.Row

c = LBound(DS)
d = UBound(DS)

ReDim B(d - 1)
For i = 1 To d
    e = i - 1
    B(e) = DS(i, 1)
Next i
    Call GrayCode(B)

Unload Me

End Sub


Private Sub UserForm_Click()

End Sub


Many thanks in advance
 

Attachments

  • 1.JPG
    1.JPG
    88.8 KB · Views: 5
  • 2.JPG
    2.JPG
    82.3 KB · Views: 5
Last edited by a moderator:
When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block at the bottom of this post has more details. I have added the tags for you this time. 😊
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top