Question

我正在尝试找到算法，将表/列表中的少量金额与ceratin数相等或可能最接近（但不大于）。

让我通过例子解释一下。我有一个带数字的清单：
{ 1.23 ; 3.45 ; 20.11 ; 100.13 ; 200.08 }

我想要的号码是123.69

所以应该{ 3.45 ; 20.11 ; 100.13 } = 123.69

如果号码为122，则不应采用相同的号码，而是{ 20.11 ; 100.13 ; 1.23 } = 121.47

有什么想法写这样的东西吗？

Answer 1

这是subset-sum problem的变体，使用DP非常容易解决仅涉及整数的经典问题，并且可以在StackOverflow周围的许多线程中找到，例如this one。

然而，您的问题中有一个小调整，使其与经典整数子集求和问题略有不同 - 您正在处理不必是整数的值，它们也有一个小数值。

在您的情况下，似乎小数值最多为2位数＆＃34;在点＆＃34;之后。这意味着，只需将数组中的所有值乘以100即可轻松将问题转换为经典的整数子集求和问题，并搜索100*x而不是x。
在你的例子中 - 你需要在整数值{123, 345, 2011, 10013, 20008}的数组中寻找12,369。

附件1： 解决整数的SubsetSum问题：
这是使用Dynamic Programming完成的，其中DP的递归公式为：

f(x,0) = FALSE if x<0
f(0,0) = TRUE
f(x,i) = f(x,i-1) OR f(x-arr[i], i-1)

通过计算上面的自下而上，您会得到一个大小为(W*100+1) x (n+1)的矩阵（其中W是您请求的总和，n是数组中元素的数量。）< / p>

通过在完成后搜索保留值true的最后一行中的列 - 您找到了＆＃34;最佳＆＃34;可能的总和，直到你的数字。

附件2 ：查找实际的数字子集。
到目前为止，你已经找到了最好的总和，但还没有找到最好的数字。为此，您需要使用矩阵（您之前计算过的），并重放您为生成此总和而执行的步骤。对this thread中的类似问题进行了解释，简而言之，它是通过以下方式完成的：

line <- BEST //best solution found
i <- n
while (i> 0):
  if table[line-array[i]][i-1] == TRUE:
      the element 'i' is in the set
      i <- i-1
      line <- line-array[i]
  else:
      i <- i-1

注意：如果这太复杂了，并且数组的大小相当小，或者在点＆＃34;之后的小数位数为＃34; 2限制是不正确的 - 你几乎必须使用指数解决方案 - 暴力，它会创建所有可能的子集，并从中选择最好的子集。在这种情况下没有（已知的）有效解决方案，因为已知此问题为NP-Hard

<强> TL; DR：将所有值乘以100，然后使用现有的整数子集求和算法找到最佳拟合值。

Answer 2

我编写的代码，在VB.NET中完美运行，但在VBA中存在问题。你可以试着帮我找错吗？

 Dim L() As Integer
bestAll = 0

K = 35.3903

ReDim list(0 To 17) As Integer
ReDim L(0 To 17) As Integer
Dim W As Integer
Dim bool As Boolean

   Dim B(16) As Double
   B(0) = 0.042
   B(1) = 0.1286
   B(2) = 0.1472
   B(3) = 0.1534
   B(4) = 0.2008
   B(5) = 1.4679
   B(6) = 1.5954
   B(7) = 2.6748
   B(8) = 12.1078
   B(9) = 12.1272
   B(10) = 12.4154
   B(11) = 12.4978
   B(12) = 15.4142
   B(13) = 28.3464
   B(14) = 34.8652
   B(15) = 38.1519
   B(16) = 42.8154
For W = 0 To 16
           bool = Proc(0, W, L, 0, B)
        Next W

和这里功能处理：

Public Function Proc(best As Double, I As Integer, L() As Integer, count As Integer, A() As Double) As Boolean
        Dim newbest As Double
        newbest = 0
        If ((best + A(I)) <= K) Then
            newbest = best + A(I)
            L(count) = I
            count = count + 1
            If (newbest > bestAll) Then
                bestAll = newbest
                listcount = count
                Dim j1 As Integer
                For j1 = 0 To count - 1
                    list(j1) = L(j1)
                Next j1
            End If
        Else
            Proc = False
        End If
        Dim j2 As Integer

        For j2 = I + 1 To wielkosctabeli - 1
            Dim promissin As Boolean
            promissin = Proc(newbest, j2, L, count, A)
            If Not promissin Then
                Exit For
            End If
        Next j2
        Proc = True
    End Function

算法采用最佳数字集合求和

2 个答案: