VBA如何编写Do循环选取Excel数据直至求和等于指定目标值

你这个需求本质是子集和问题，28万行的数据量下，别写那种逐行枚举的暴力Do循环，算到宇宙毁灭都出不了结果，必须先做数据剪枝，再用栈结构配合Do循环实现带回溯的查找逻辑，才能在可接受的时间内跑出结果。

• 先筛除所有金额大于1500000的行：这类小票只要选了总额直接超标，完全没有参与计算的必要，先批量删掉减少数据量。
• 把剩余数据按金额降序排序：从大额小票开始凑，能最快触发“加了就超”的剪枝条件，比乱序/升序的计算效率高上万倍。
• 把清洗完的金额数据一次性读入VBA数组，全程在内存里运算，不要每次循环都读单元格——单元格对象的读写速度比内存数组慢上百倍，28万行数据直接操作单元格会卡到死机。

先初始化固定变量：

Const TARGET As Double = 1500000
Dim dataArr() As Double ' 存清洗排序后的所有小票金额
Dim currentSum As Double ' 当前选中小票的总金额，初始为0
Dim stack() As Long ' 存当前选中的小票在数组里的索引，模拟选择路径
Dim ptr As Long ' 当前遍历到的数组下标，初始为0
Dim timeOut As Date ' 超时时间，避免无意义等待
currentSum = 0
ptr = 0
ReDim stack(-1 To -1) ' 初始化空栈
timeOut = Now() + TimeSerial(0, 10, 0) ' 设10分钟超时，可自行调整

外层套Do循环，触发终止条件就退出：

Do
    ' 终止条件1：找到精确解（浮点运算留0.01美元容差），直接退出
    If Abs(currentSum - TARGET) < 0.01 Then
        Exit Do
    End If
    ' 终止条件2：超时，退出返回当前最接近的近似解
    If Now() > timeOut Then
        Exit Do
    End If
    ' 终止条件3：所有组合遍历完没找到解，退出
    If ptr > UBound(dataArr) And UBound(stack) < 0 Then
        Exit Do
    End If

    If currentSum < TARGET And ptr <= UBound(dataArr) Then
        ' 尝试加当前指针指向的小票，不超目标就选中
        If currentSum + dataArr(ptr) <= TARGET + 0.01 Then
            ' 把当前索引压栈，累加金额，指针下移
            ReDim Preserve stack(UBound(stack) + 1)
            stack(UBound(stack)) = ptr
            currentSum = currentSum + dataArr(ptr)
            ptr = ptr + 1
        Else
            ' 加了就超，直接跳过这个小票，指针下移
            ptr = ptr + 1
        End If
    Else
        ' 指针走到头还没凑够，回溯退一步
        Dim lastIdx As Long
        lastIdx = stack(UBound(stack))
        ' 把最后选的小票弹出栈，减去对应金额
        currentSum = currentSum - dataArr(lastIdx)
        If UBound(stack) = 0 Then
            ReDim stack(-1 To -1)
        Else
            ReDim Preserve stack(UBound(stack) - 1)
        End If
        ' 指针移到被弹出小票的下一位，重新尝试
        ptr = lastIdx + 1
    End If
Loop

循环结束后，stack数组里存的索引对应的小票，就是符合要求（或者超时情况下最接近要求）的结果，直接读出来写到工作表里即可。

28万条随机数值的精确子集和本身存在的概率极低，不要死等精确结果。如果业务允许小额误差，可以在凑到剩余差额小于你设定的误差阈值（比如1美元）时，直接从剩余小票里找和差额最接近的小票补上，几秒就能出可用结果，没必要跑几小时找精确解。
别尝试纯暴力逐行枚举的Do循环写法：28万条数据的可选组合数是2的28万次方，这个量级的计算量哪怕用超级计算机都跑不完，没有剪枝的逻辑写了也是白写。

内容的提问来源于stack exchange，提问作者lbochitt