小金额优先,分离出5000数据.求程序或公式

bosshome

表1数据是数量统计
表2数据要求自动分离出来. 小金额优先.
表3数据是剩余数.
跪求大神公式或都vba程序, 谢谢.
文档为excel.
要求 总数表1己知数量,自动用公式分离出取零钱最多的5000块钱表2,和剩下的钱表3.zip (9.25 KB, 下载次数: 11)

2022-12-16 14:35 上传

点击文件名下载附件

3190496160

Sub test()
Dim ar As Variant
Dim brr(), crr()
With Sheet1
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    ar = .Range("a1:c" & r)
    For i = 5 To UBound(ar)
        For s = i + 1 To UBound(ar)
            If ar(i, 3) < ar(s, 3) Then
                For j = 1 To 3
                    k = ar(i, j)
                    ar(i, j) = ar(s, j)
                    ar(s, j) = k
                Next j
            End If
        Next s
    Next i
    ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
    ReDim brr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = UBound(ar) To 5 Step -1
        sl = sl + ar(i, 3)
        If sl < 5000 Then
            n = n + 1
            For j = 1 To 3
                arr(n, j) = ar(i, j)
            Next j
            m = m + 1
            brr(m, 1) = ar(i, 1)
            brr(m, 2) = 0
            brr(m, 3) = 0
        Else
            ys = sl - 5000
            n = n + 1
            xh = i
            arr(n, 1) = ar(i, 1)
            arr(n, 2) = (ar(i, 3) - ys) / ar(i, 1)
            arr(n, 3) = ar(i, 3) - ys
            Exit For
        End If
    Next i
    For i = xh To 5 Step -1
        m = m + 1
        If i = xh Then
            brr(m, 1) = ar(i, 1)
            brr(m, 2) = ys / ar(i, 1)
            brr(m, 3) = ys
        Else
            For j = 1 To 3
                brr(m, j) = ar(i, j)
            Next j
        End If
    Next i
    .[f5].Resize(n, 3) = arr
    .[j5].Resize(m, 3) = brr
End With
End Sub

3190496160

仅供参考
要求 总数表1己知数量,自动用公式分离出取零钱最多的5000块钱表2,和剩下的钱表3.rar (22.66 KB, 下载次数: 9)

2022-12-16 16:13 上传

点击文件名下载附件

2900357148

代码应该可以再优化一下，测试没发现什么问题，楼主试一下看看

bosshome

2900357148 发表于 2022-12-16 16:14
代码应该可以再优化一下，测试没发现什么问题，楼主试一下看看

为什么下载excel后文件里面没有VBA呢.

bosshome

2900357148

bosshome 发表于 2022-12-16 17:16

Office版本不一样？我把代码发出来吧，你自己添加一个模块放进去就行了。

Option Explicit
Public DlbSurplusValue As Double
Public DlbTempSum As Double
Public IntFaceValueCnt%, IntNumber%
Public ArrInfo
Sub 优先小金额凑5000块()
    ArrInfo = Range("A3").CurrentRegion
    '初步判断哪些面值的钱之和第一次超过5000
    Call 计算面值数量(5000)
    Cells(IntNumber + 2, 7) = ArrInfo(IntNumber, 2) - IntFaceValueCnt '单独计算目前使用最大面值的数量
    Do Until DlbSurplusValue = 0
        Call 计算面值数量(DlbSurplusValue)
    Loop
End Sub
Sub 计算面值数量(MaxValue As Double)
    Dim i%
    DlbTempSum = 0
    If MaxValue = 5000 Then
        For i = UBound(ArrInfo, 1) - 1 To LBound(ArrInfo, 1) + 2 Step -1
            If DlbTempSum < MaxValue Then
                DlbTempSum = DlbTempSum + ArrInfo(i, 1) * ArrInfo(i, 2)
                Cells(i + 2, 7).Value = ArrInfo(i, 2)
                IntNumber = i
            Else
                Exit For
            End If
        Next i
    Else
        For i = LBound(ArrInfo, 1) + 2 To UBound(ArrInfo, 1) - 1
            IntFaceValueCnt = Split(MaxValue / ArrInfo(i, 1), ".")(0)
            If IntFaceValueCnt > 0 Then Cells(i + 2, 7).Value = ArrInfo(i, 2) - IntFaceValueCnt: Exit For
        Next i
    End If
    If MaxValue = 5000 Then
        IntFaceValueCnt = Split((DlbTempSum - MaxValue) / ArrInfo(IntNumber, 1), ".")(0)
        DlbSurplusValue = DlbTempSum - MaxValue - IntFaceValueCnt * ArrInfo(IntNumber, 1)
    Else
        DlbSurplusValue = MaxValue - IntFaceValueCnt * ArrInfo(i, 1)
    End If
End Sub

2900357148

代码我重发了，还在审核，楼主稍微等一下

zxsea_7426

3190496160 发表于 2022-12-16 16:13
仅供参考

运行结果是这样的:
[应该有哪里没有考虑到，钞票不能撕开来算，必须是整数]

bosshome

1块钱那里数量是1 的话会出错.