從列表中提取數據，直到滿足指定的總數

Question

我有2個堆疊在彼此之上的數據列表。這些是我需要頂部列表總數儘可能接近單元格I10中主表單上指定數量的帳戶列表。在過去的一段時間裏，我一直在手動執行此操作。例如，如果我需要所有帳戶的總和接近10億，我就開始複製粘貼頂部列表中的值並將它們放在底部列表中，直到頂部列表的總和爲止約10億。我最初編寫了一些VB代碼，它們只是從列表1的底部開始考慮值，並將它們放在列表2的底部，直到總和低於10億，但問題在於最後一個從列表中拉出的數字1的可笑程度很大，所以我的總數遠低於我的10億美元範圍。

我的新方法（可能很差）是先按照上面的方法做，然後在底部列表中搜索小值，然後將它們放回頂部列表中，直到我接近10億。 （我可以超過或低於10億，但不是極端的數額）哦，而且，我的名單是不斷變化的大小..也就是說這需要動態的（並且名單2有空單元格的可能性）

下面是我的第一次嘗試，讓我的總數太少。

如果有人能幫我弄清楚如何做到這一點，我會非常感激。

If Worksheets("Output").Range("B1").End(xlDown).Offset(2) > (Worksheets("Master Sheet").Range("I10").Value + 0.1) * 1000000 Then 
     Do 
      Worksheets("Output").Range("A1").End(xlDown).Select 
      Range(ActiveCell, ActiveCell.End(xlToRight).Offset(, 3)).Cut 
      Worksheets("Output").Range("A65000").End(xlUp).Offset(-1).Select 
      Selection.Insert Shift:=xlDown 
     Loop Until Worksheets("Output").Range("B1").End(xlDown).Offset(2) < (Worksheets("Master Sheet").Range("I10") + 0.1) * 1000000 
    End If 

Answer 1

下面是我用來查找總數達到某個值的組合的代碼。

我把它迷上這部長達一個窗體，所以只是手動提供值：

MaxSoln =被發現

最大的解決方案

TargetVal =需要合計到

值SearchRange =您的值存儲在Excel中的範圍

Option Explicit 

Function RealEqual(A, B, Optional Epsilon As Double = 0.00000001) 
    RealEqual = Abs(A - B) <= Epsilon 
    End Function 
Function ExtendRslt(CurrRslt, NewVal, Separator) 
    If CurrRslt = "" Then ExtendRslt = NewVal _ 
    Else ExtendRslt = CurrRslt & Separator & NewVal 
    End Function 
Sub recursiveMatch(ByVal MaxSoln As Long, ByVal TargetVal, InArr(), _ 
     ByVal HaveRandomNegatives As Boolean, _ 
     ByVal CurrIdx As Long, _ 
     ByVal CurrTotal, ByVal Epsilon As Double, _ 
     ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String) 
On Error Resume Next 
    Dim i As Long 
    For i = CurrIdx To UBound(InArr) 
     If RealEqual(CurrTotal + InArr(i), TargetVal, Epsilon) Then 
      Rslt(UBound(Rslt)) = ("Totaled to: " & CombinationFinder.TotalTo.Value) _ 
       & Separator & ExtendRslt(CurrRslt, InArr(i), Separator) 
      If MaxSoln = 0 Then 
      Else 
       If UBound(Rslt) >= MaxSoln Then Exit Sub 
       End If 
      ReDim Preserve Rslt(UBound(Rslt) + 1) 
     ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(i) > TargetVal + Epsilon) Then 
     ElseIf CurrIdx < UBound(InArr) Then 
      recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _ 
       i + 1, _ 
       CurrTotal + InArr(i), Epsilon, Rslt(), _ 
       ExtendRslt(CurrRslt, InArr(i), Separator), _ 
       Separator 
      If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub 
     Else 
      'we've run out of possible elements and we _ 
      still don't have a match 
      End If 
     Next i 
    End Sub 
Function ArrLen(Arr()) As Long 
    On Error Resume Next 
    ArrLen = UBound(Arr) - LBound(Arr) + 1 
    End Function 
Function checkRandomNegatives(Arr) As Boolean 
    Dim i As Long 
    i = LBound(Arr) 
    Do While Arr(i) < 0 And i < UBound(Arr): i = i + 1: Loop 
    If i = UBound(Arr) Then Exit Function 
    Do While Arr(i) >= 0 And i < UBound(Arr): i = i + 1: Loop 
    checkRandomNegatives = Arr(i) < 0 
    End Function 
Sub startSearch() 
    'The selection should be a single contiguous range in a single column. _ 
    The first cell indicates the number of solutions wanted. Specify zero for all. _ 
    The 2nd cell is the target value. _ 
    The rest of the cells are the values available for matching. _ 
    The output is in the column adjacent to the one containing the input data. 
    Dim searchrange As Range 
    Set searchrange = Range(CombinationFinder.RefRange) 

    If Not TypeOf searchrange Is Range Then GoTo ErrXIT 
    If searchrange.Areas.Count > 1 Or searchrange.Columns.Count > 1 Then GoTo ErrXIT 
    If searchrange.Rows.Count < 3 Then GoTo ErrXIT 

    Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Long, _ 
     HaveRandomNegatives As Boolean 

    MaxSoln = CombinationFinder.Max.Value 
    TargetVal = CombinationFinder.TotalTo.Value 

    InArr = Application.WorksheetFunction.Transpose(searchrange) 
    HaveRandomNegatives = checkRandomNegatives(InArr) 
    If Not HaveRandomNegatives Then 
    ElseIf MsgBox("At least 1 negative number is present between positive numbers" _ 
       & vbNewLine _ 
      & "It may take a lot longer to search for matches." & vbNewLine _ 
      & "OK to continue else Cancel", vbOKCancel) = vbCancel Then 
     Exit Sub 
     End If 

    ReDim Rslt(0) 
    recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, LBound(InArr), 0, 0.00000001, Rslt, "", ", " 
    ActiveSheet.Range("A1:A" & ArrLen(Rslt)) = Application.WorksheetFunction.Transpose(Rslt) 
    Exit Sub 
ErrXIT: 
    MsgBox "Please select cells in a single column before using this macro" & vbNewLine _ 
     & "The selection should be a single contiguous range in a single column." & vbNewLine _ 
     & "The first cell indicates the number of solutions wanted. Specify zero for all." & vbNewLine _ 
     & "The 2nd cell is the target value." & vbNewLine _ 
     & "The rest of the cells are the values available for matching." & vbNewLine _ 
     & "The output is in the column adjacent to the one containing the input data." 
    End Sub