Question

我有两个堆叠在彼此顶部的数据列表。这些是帐户列表，其中我需要顶部列表的总数尽可能接近单元格I10中主表单上指定的数字。在过去的一段时间里，我一直在手动执行此操作。例如，如果我需要所有帐户的总和尽可能接近10亿，我开始复制并粘贴顶部列表中的值并将它们放在底部列表中，直到顶部列表的总和为大约10亿。我最初编写了一些vb代码，它只是从列表一的底部开始考虑值，并将它们放在列表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

从列表中提取数据，直到达到指定的总数

1 个答案: