随机凑数

Sub test()
    tms = Timer
    h = [e2] '目标和值h
    g = [g2] '凑数计算精度g 即Round函数的第2参数位数指定
    m = [a1].End(4).Row - 1 '有效元素个数m
    ar = [a2].Resize(m, 2)
    For i = 1 To m
        ar(i, 1) = i
    Next
    [b2].Resize(m).Sort [b2], 1, , , , , , 2 '数据排序
    br = [b2].Resize(m)
    s = h
    For i = m To 1 Step -1
        If br(i, 1) < s Then n1 = n1 + 1: s = s - br(i, 1) Else n1 = n1 + 1: [i4] = n1: Exit For '最少个数n1
    Next
    s = h
    For i = 1 To m
        If br(i, 1) < s Then s = s - br(i, 1) Else n2 = i - 1: [j4] = n2: Exit For '最多个数n2
    Next
    [a2].Resize(m, 2) = ar
    [c2].Resize(m) = ""
    [g4] = ""
Redo:
    cnt = 0: [g4] = [g4] + 1
    n = [e4] '指定个数n
    If n = 0 Then n = m Else If [g4] > 10 Then n = m Else If n < n1 Or n > n2 Then n = m
    '不指定n时、或随机次数超过10次仍未算出结果时、或指定n超允许范围n1,n2时：一律改为个数随机不指定。
    s = h
    Randomize
    For i = 1 To n '随机洗牌指定次数n、或接近目标值时停止
        r = Int(Rnd * (m - i + 1)) + i
        If n = m Then If s < ar(r, 2) Then n = i - 1: Exit For
        t = ar(r, 1): ar(r, 1) = ar(i, 1): ar(i, 1) = t
        t = ar(r, 2): ar(r, 2) = ar(i, 2): ar(i, 2) = t
        s = s - t
    Next
    Do While Int(s * 10 ^ g) '随机交换直至误差<0.5*10^-g时 g=1是<0.05时
        cnt = cnt + 1
        '        If cnt Mod 1000 = 0 Then DoEvents
        If cnt > 10000 Then GoTo Redo '万次随机无果时重新做
        i = Int(Rnd * n) + 1
        r = Int(Rnd * (m - n)) + n + 1
        s1 = s + ar(i, 2) - ar(r, 2)
        If Abs(s1) < Abs(s) Then '差值更小时，随机交换
            t = ar(i, 1): ar(i, 1) = ar(r, 1): ar(r, 1) = t
            t = ar(i, 2): ar(i, 2) = ar(r, 2): ar(r, 2) = t
            s = s + t - ar(i, 2)
        End If
    Loop
    '    Debug.Print cnt '计算完成
    '本打算对随机结果进行1对1的组合微调，但效果不明显。
    '    For i = 1 To n
    '        For r = n + 1 To m
    '            If s = ar(r, 2) - ar(i, 2) Then
    '                t = ar(i, 1): ar(i, 1) = ar(r, 1): ar(r, 1) = t
    '                t = ar(i, 2): ar(i, 2) = ar(r, 2): ar(r, 2) = t
    '                Stop
    '                Exit For
    '            End If
    '        Next
    '        If r <= m Then Exit For
    '    Next
    [h4] = Format(Timer - tms, "0.000s")
    ReDim cr(1 To m, 1 To 1) '输出结果
    s = 0
    For i = 1 To n
        s = s + ar(i, 2)
        cr(ar(i, 1), 1) = 1
        '        Cells(ar(i, 1) + 1, 3) = 1
    Next
    [c2].Resize(m) = cr
    MsgBox "本次差值: " & s - h
End Sub