Question

我想找到加总数（十进制或整数）的十进制数组合。我复制的以下代码（感谢marcw）适用于整数，但不适用于小数。如果有人可以帮助修改，感激不尽。谢谢

Sub Test_AllSumsForTotalFromSet()
Dim numberSet, total As Long, result As Collection

numberSet = Array(65536, 131072, 262144, 524288, 104576, 2097152)
total = 366720

Set result = GetAllSumsForTotalFromSet(total, numberSet)

Debug.Print "Possible sums: " & result.count

PrintResult result
End Sub

   Function GetAllSumsForTotalFromSet(total As Long, ByRef numberSet As    Variant) As Collection
   Set GetAllSumsForTotalFromSet = New Collection
   Dim partialSolution(1 To 1) As Long

   Set GetAllSumsForTotalFromSet = AllSumsForTotalFromSet(total, numberSet,UBound(numberSet), partialSolution)
   End Function

   Function AllSumsForTotalFromSet(total As Long, ByRef numberSet As Variant, numberSetIndex As Long, ByRef partialSolution() As Long) As Collection
   Dim index As Long, number As Long, result As Collection

 Set AllSumsForTotalFromSet = New Collection

'break if numberSetIndex is too small
If numberSetIndex < LBound(numberSet) Then Exit Function

For index = numberSetIndex To LBound(numberSet) Step -1
    number = numberSet(index)

    If number <= total Then
        'append the number to the partial solution
        partialSolution(UBound(partialSolution)) = number

        If number = total Then
            AllSumsForTotalFromSet.Add partialSolution

        Else
            Set result = AllSumsForTotalFromSet(total - number, numberSet, index, CopyAndReDimPlus1(partialSolution))
            AppendCollection AllSumsForTotalFromSet, result
        End If
    End If
Next index
End Function

'copy the passed array and increase the copy's size by 1
Function CopyAndReDimPlus1(ByVal sourceArray As Variant) As Long()
Dim i As Long, destArray() As Long
ReDim destArray(LBound(sourceArray) To UBound(sourceArray) + 1)

For i = LBound(sourceArray) To UBound(sourceArray)
    destArray(i) = sourceArray(i)
Next i

CopyAndReDimPlus1 = destArray
End Function

'append sourceCollection to destCollection
Sub AppendCollection(ByRef destCollection As Collection, ByRef sourceCollection As Collection)
Dim e
For Each e In sourceCollection
    destCollection.Add e
Next e
End Sub
Sub PrintResult(ByRef result As Collection)
Dim r, a

For Each r In result
    For Each a In r
        Debug.Print a;
    Next
    Debug.Print
Next
End Sub




The code worked perfectly for sample data-1. It success fully identified the combination 4026352.91 and 3321372.09. 
However, the code failed when I used the sample data-2. 
It gave an error as'overflow'in attempt 1 and simply hanged in the second   attempt(Not Responding). Day deals are the combinations to lookout and day batch deal is the total


SAMPLE DATA - I:

DAY DEALS   DAY BATCH DEAL 
1355010.53  7347725.00
1356282.66  
2314895.60  
4026352.91
5018529.40  
5327217.35  
6998114.48  
3321372.09
8006400.00  
16366000.00 
23367750.00 
28035000.00 
352239.75   
SAMPLE DATA - II:  
DAY DEALS      DAY BATCH DEAL 
22157210.49    62393700.00
40236489.51 
15475.82    
16426.03    
1695136.51  
4043508.15  
4719310.44  
6688073.98  
14221991.85 
29777089.56 
35259363.49 
48642124.18

查找集合中的十进制数组合可累计给定的总VBA

0 个答案: