拼凑和值问题请教

鄂龙蒙

请教：A列为备选数，选取A列从A1开始向下N个数加和，使得其和“拼凑和值”离目标值差额最小（必须小于或等于目标值）
这样的代码怎么写？谢谢！

求助问题.rar (8.29 KB, 下载次数: 16)

2017-8-3 10:16 上传

点击文件名下载附件

chengshanming

查一下，“香川裙子"老师的凑数字凑金额的最佳递归程序！

cvvb0606

'56298个组合，稍微等一会，10s左右
Option Explicit

Dim output(), cnt

Sub test()
  Dim arr, brr, i, result()
  ReDim arr([a65536].End(xlUp).Row - 1)
  For i = 1 To UBound(arr)
    arr(i) = Cells(i, 1)
  Next
  dsort arr: cnt = 0: ReDim output(1 To 1)
  For i = 1 To UBound(arr) + 1
    ReDim result(i)
    combine_decrease arr, UBound(arr) + 1, result, i, i, [d11].Value
  Next
  [k:k].ClearContents
  If cnt > 0 Then [k1].Resize(UBound(output), 1) = WorksheetFunction.Transpose(output)
End Sub

Function dsort(arr)
  Dim i, j, t
  For i = LBound(arr) To UBound(arr) - 1
    For j = i + 1 To UBound(arr)
      If arr(i) < arr(j) Then
        t = arr(i): arr(i) = arr(j): arr(j) = t
      End If
  Next j, i
End Function

Function combine_decrease(arr, start, result, count, num, t)
  Dim i
  For i = start To count Step -1
    result(count - 1) = i - 1
    If count > 1 Then
      combine_decrease arr, i - 1, result, count - 1, num, t
    Else
      Dim j, sum
      For j = num - 1 To 0 Step -1: sum = sum + arr(result(j)): Next
      If sum = t Then
        cnt = cnt + 1
        ReDim Preserve output(1 To cnt)
        For j = num - 1 To 0 Step -1: output(cnt) = output(cnt) & arr(result(j)) & "+": Next
        output(cnt) = Left(output(cnt), Len(output(cnt)) - 1) & "=" & t
      End If
      If sum > t Then Exit For
      sum = 0
    End If
  Next
End Function

鄂龙蒙

cvvb0606 发表于 2017-8-3 18:42
'56298个组合，稍微等一会，10s左右
Option Explicit

谢谢您！
我是想要从A1开始向下组合，求出与设定值最接近的小于或等于的那个数的行号等。

cvvb0606

鄂龙蒙 发表于 2017-8-3 18:49
谢谢您！
我是想要从A1开始向下组合，求出与设定值最接近的小于或等于的那个数的行号等。

再加个条件
if t-sum<=d then 'd就是偏差
end if

cvvb0606

'52146，刚才算错了。组合太多，设置了一个小偏差等了一会儿就中断了，估计符合条件的太多。
Option Explicit

Dim output(), cnt

Sub test()
  Dim arr, brr, i, result()
  ReDim arr([a65536].End(xlUp).Row - 1)
  For i = 0 To UBound(arr)
    arr(i) = Cells(i + 1, 1)
  Next
  dsort arr: cnt = 0: ReDim output(1 To 1)
  For i = 1 To UBound(arr) + 1
    ReDim result(i)
    combine_decrease arr, UBound(arr) + 1, result, i, i, [d11].Value
  Next
  [k:k].ClearContents
  If cnt > 0 Then [k1].Resize(UBound(output), 1) = WorksheetFunction.Transpose(output)
End Sub

Function dsort(arr)
  Dim i, j, t
  For i = LBound(arr) To UBound(arr) - 1
    For j = i + 1 To UBound(arr)
      If arr(i) < arr(j) Then
        t = arr(i): arr(i) = arr(j): arr(j) = t
      End If
  Next j, i
End Function

Function combine_decrease(arr, start, result, count, num, t)
  Dim i
  For i = start To count Step -1
    result(count - 1) = i - 1
    If count > 1 Then
      combine_decrease arr, i - 1, result, count - 1, num, t
    Else
      Dim j, sum
      For j = num - 1 To 0 Step -1: sum = sum + arr(result(j)): Next
      If sum = t Then
        cnt = cnt + 1
        ReDim Preserve output(1 To cnt)
        For j = num - 1 To 0 Step -1: output(cnt) = output(cnt) & arr(result(j)) & "+": Next
        output(cnt) = Left(output(cnt), Len(output(cnt)) - 1) & "=" & t
      End If
      If sum > t Then Exit For
      sum = 0
    End If
  Next
End Function

cvvb0606

cvvb0606 发表于 2017-8-3 20:17
'52146，刚才算错了。组合太多，设置了一个小偏差等了一会儿就中断了，估计符合条件的太多。
Option Expli ...

刚才错位了，把0也算进去了。

鄂龙蒙

cvvb0606 发表于 2017-8-3 20:19
刚才错位了，把0也算进去了。

谢谢您！我想要的从A1向下连续相加，不是要多种组合。

cvvb0606

鄂龙蒙 发表于 2017-8-3 20:23
谢谢您！我想要的从A1向下连续相加，不是要多种组合。

就是一个组合问题啊，给出所有答案。你这连续可能是一个数或者是所有数相加。
如果只是顺序相加那口算就能得出结论，那这问题就没有意义了的吧。

风雨相随3

cvvb0606 发表于 2017-8-3 18:42
'56298个组合，稍微等一会，10s左右
Option Explicit

论坛里怎么不能上传附件？