VBA to find combination of values to target sum

[Oakwoodbespoke]

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

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

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

 

[Peter_SSs]

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.

 

[Oakwoodbespoke]

Thanks Peter will do