怎么让Excel取几个求和的数呢？
How to let Excel pick up several numbers that give a sum wanted?
我不确定如何更好地表达这个问题，但请看下面的图片。基本上，在这个例子中，我有一个数字作为目标，10（在左边）。然后，我在右边有一个数字列表，上面有我可以选择的一堆数字。我正在寻找一种方法 select 从数字列表中选择一定数量的数字，使这些数字的总和等于目标数字。在下面的示例中，正确答案是选择“5”、“3”和“2”。
欢迎使用菜单栏中的任何 excel 功能、工具或 VBA 代码。
所以，就像这样：
=sumproduct(C5:C10,D5:D10)
是单元格 B8 中的公式，是求解器中的 objective。
这两个约束控制着模型，请务必检查选项以确保未选择“忽略整数”。
使用二进制，因为这是选择或未选择的情况。
我在约束中使用等于，但在某些情况下您可能需要使用 <= 或 >=，因为可能没有精确的解决方案。
Solver 也处理相同的多个值，这与其他答案不同，但是，由于存在多个解决方案，因此选择的是随机的：
我已经设法为此制定了 VBA 解决方案。我已经测试了多个不同的 goals/targets 和不同范围的数字，以便每次求和和工作。不能保证没有问题它不会解决。
这里是：
注意 - 您现在应该可以拥有多个相同的号码。这只会 return 它找到的第一个解决方案。它没有找到所有解决方案。
Sub SumSolver()
Dim rng, Goal As Double, ws As Worksheet, i As Long, j As Long, Answer As Double, k As Long
Dim lRow As Long, Answerlist As String, LastAdded As Long, AnswerListPos As String
Dim c As Range, RngToSplit As String, AnswerArray, AnswerItem
Set ws = Sheets("Sheet1") 'Change Sheet1 to your sheet name
lRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row 'Change to needed column
ws.Range("C2:C" & lRow).ClearContents 'Clear output range if needed
For Each c In ws.Range("B2:B" & lRow) 'This loop populates the list range into a string
If c.Value <> "" Or Not IsNumeric(c.Value) Then 'Checking for empty or non-numeric values
If RngToSplit = "" Then
RngToSplit = c.Value
Else
RngToSplit = RngToSplit & "," & c.Value
End If
End If
Next
rng = Split(RngToSplit, ",") 'Split the new list string into an array
If Not IsNumeric(ws.Range("A2").Value) Then 'Checks target value is actually a number
MsgBox "The target value is not a valid number. Please correct this before trying again.", vbExclamation, "Sum Solver"
Exit Sub
Else
Goal = ws.Range("A2").Value 'Value of the goal/target
End If
For i = 0 To UBound(rng) ' 0 = start of array, Ubound = End of array
If rng(i) = Goal Then
ws.Range("C2") = rng(i)
Answerlist = rng(i)
GoTo SubExit
ElseIf rng(i) < Goal Then
Answer = rng(i)
Answerlist = rng(i)
AnswerListPos = i
For j = i + 1 To UBound(rng)
If Answer + rng(j) = Goal Then
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
GoTo SubExit
ElseIf Answer + rng(j) < Goal Then
Answer = Answer + rng(j)
LastAdded = j
If Answerlist = "" Then
Answerlist = rng(j)
AnswerListPos = j
Else
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
End If
End If
If j = UBound(rng) Then
If LastAdded = UBound(rng) Then
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
Answer = Answer - rng(j)
LastAdded = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
End If
If LastAdded > 0 Then Answer = Answer - rng(LastAdded)
If InStr(Answerlist, ",") = 0 Then Exit For
j = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
End If
Next j
End If
Answerlist = ""
Next i
SubExit:
If Answerlist <> "" Then
i = 2
AnswerArray = Split(Answerlist, ",") 'Split the result into an array
For Each AnswerItem In AnswerArray
ws.Range("C" & i) = AnswerItem 'Output the results into the sheet
i = i + 1
Next
Else
MsgBox "No possible combination found for a target value of " & Goal & ".", vbExclamation, "Sum Solver"
End If
End Sub
编辑： 刚刚更新以说明列表范围内是否有任何空白行以及处理值是否为非数字。对于 1000 次迭代的 12 项列表，实际上使它快了半秒（13 秒）。
您会看到我评论过的行是您需要更改的行。几乎就是它正在处理的列和起始单元格它可以查看最后一行，但如果你不需要它，那么只需将 "B2:B" & lRow 替换为 B2:B5 等
我也把它合并到一个函数中了。用作：
=SumSolver(Target value, Range of sum values)
它 return 在同一个单元格中以逗号分隔的结果。不过，如果需要，可以轻松将其更改为另一种方法。
Function SumSolver(Goal As Double, ListRange As Range)
Dim i As Long, j As Long, Answer As Double, k As Long, rng As Variant
Dim Answerlist As String, LastAdded As Long, AnswerListPos As String
rng = Application.Transpose(ListRange)
For i = 1 To UBound(rng)
If rng(i) = Goal Then
Answerlist = rng(i)
GoTo SubExit
ElseIf rng(i) < Goal Then
Answer = rng(i)
Answerlist = rng(i)
AnswerListPos = i
For j = i + 1 To UBound(rng)
If Answer + rng(j) = Goal Then
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
GoTo SubExit
ElseIf Answer + rng(j) < Goal Then
Answer = Answer + rng(j)
LastAdded = j
If Answerlist = "" Then
Answerlist = rng(j)
AnswerListPos = j
Else
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
End If
End If
If j = UBound(rng) Then
If LastAdded = UBound(rng) Then
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
Answer = Answer - rng(j)
LastAdded = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
End If
If LastAdded > 0 Then Answer = Answer - rng(LastAdded)
If InStr(Answerlist, ",") = 0 Then Exit For
j = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
End If
Next j
End If
Answerlist = ""
Next i
SubExit:
If Answerlist <> "" Then
SumSolver = Answerlist
Else
SumSolver = "N/A"
End If
End Function
示例：
我决定更新我的速度测试。这次将更新后的代码与我的原始代码进行比较，并惊讶地发现了差异。我运行了 1000 次迭代，求解器找不到组合。我在屏幕更新的情况下做到了这一点。对于 8 个列表，最多有 255 个组合，对于 12 个列表，最多有 4095 个组合（添加每个项目时加倍）。对于 12 个列表，计算量为 4,095,000 次。更新后的代码平均耗时 13.6 秒。显然这是在我的机器上，结果与你的不同（但比率应该大致相同）。
我不确定如何更好地表达这个问题，但请看下面的图片。基本上，在这个例子中，我有一个数字作为目标，10（在左边）。然后，我在右边有一个数字列表，上面有我可以选择的一堆数字。我正在寻找一种方法 select 从数字列表中选择一定数量的数字，使这些数字的总和等于目标数字。在下面的示例中，正确答案是选择“5”、“3”和“2”。
欢迎使用菜单栏中的任何 excel 功能、工具或 VBA 代码。
所以，就像这样：
=sumproduct(C5:C10,D5:D10)
是单元格 B8 中的公式，是求解器中的 objective。
这两个约束控制着模型，请务必检查选项以确保未选择“忽略整数”。
使用二进制，因为这是选择或未选择的情况。
我在约束中使用等于，但在某些情况下您可能需要使用 <= 或 >=，因为可能没有精确的解决方案。
Solver 也处理相同的多个值，这与其他答案不同，但是，由于存在多个解决方案，因此选择的是随机的：
我已经设法为此制定了 VBA 解决方案。我已经测试了多个不同的 goals/targets 和不同范围的数字，以便每次求和和工作。不能保证没有问题它不会解决。
这里是：
注意 - 您现在应该可以拥有多个相同的号码。这只会 return 它找到的第一个解决方案。它没有找到所有解决方案。
Sub SumSolver()
Dim rng, Goal As Double, ws As Worksheet, i As Long, j As Long, Answer As Double, k As Long
Dim lRow As Long, Answerlist As String, LastAdded As Long, AnswerListPos As String
Dim c As Range, RngToSplit As String, AnswerArray, AnswerItem
Set ws = Sheets("Sheet1") 'Change Sheet1 to your sheet name
lRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row 'Change to needed column
ws.Range("C2:C" & lRow).ClearContents 'Clear output range if needed
For Each c In ws.Range("B2:B" & lRow) 'This loop populates the list range into a string
If c.Value <> "" Or Not IsNumeric(c.Value) Then 'Checking for empty or non-numeric values
If RngToSplit = "" Then
RngToSplit = c.Value
Else
RngToSplit = RngToSplit & "," & c.Value
End If
End If
Next
rng = Split(RngToSplit, ",") 'Split the new list string into an array
If Not IsNumeric(ws.Range("A2").Value) Then 'Checks target value is actually a number
MsgBox "The target value is not a valid number. Please correct this before trying again.", vbExclamation, "Sum Solver"
Exit Sub
Else
Goal = ws.Range("A2").Value 'Value of the goal/target
End If
For i = 0 To UBound(rng) ' 0 = start of array, Ubound = End of array
If rng(i) = Goal Then
ws.Range("C2") = rng(i)
Answerlist = rng(i)
GoTo SubExit
ElseIf rng(i) < Goal Then
Answer = rng(i)
Answerlist = rng(i)
AnswerListPos = i
For j = i + 1 To UBound(rng)
If Answer + rng(j) = Goal Then
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
GoTo SubExit
ElseIf Answer + rng(j) < Goal Then
Answer = Answer + rng(j)
LastAdded = j
If Answerlist = "" Then
Answerlist = rng(j)
AnswerListPos = j
Else
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
End If
End If
If j = UBound(rng) Then
If LastAdded = UBound(rng) Then
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
Answer = Answer - rng(j)
LastAdded = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
End If
If LastAdded > 0 Then Answer = Answer - rng(LastAdded)
If InStr(Answerlist, ",") = 0 Then Exit For
j = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
End If
Next j
End If
Answerlist = ""
Next i
SubExit:
If Answerlist <> "" Then
i = 2
AnswerArray = Split(Answerlist, ",") 'Split the result into an array
For Each AnswerItem In AnswerArray
ws.Range("C" & i) = AnswerItem 'Output the results into the sheet
i = i + 1
Next
Else
MsgBox "No possible combination found for a target value of " & Goal & ".", vbExclamation, "Sum Solver"
End If
End Sub
编辑： 刚刚更新以说明列表范围内是否有任何空白行以及处理值是否为非数字。对于 1000 次迭代的 12 项列表，实际上使它快了半秒（13 秒）。
您会看到我评论过的行是您需要更改的行。几乎就是它正在处理的列和起始单元格它可以查看最后一行，但如果你不需要它，那么只需将 "B2:B" & lRow 替换为 B2:B5 等
我也把它合并到一个函数中了。用作：
=SumSolver(Target value, Range of sum values)
它 return 在同一个单元格中以逗号分隔的结果。不过，如果需要，可以轻松将其更改为另一种方法。
Function SumSolver(Goal As Double, ListRange As Range)
Dim i As Long, j As Long, Answer As Double, k As Long, rng As Variant
Dim Answerlist As String, LastAdded As Long, AnswerListPos As String
rng = Application.Transpose(ListRange)
For i = 1 To UBound(rng)
If rng(i) = Goal Then
Answerlist = rng(i)
GoTo SubExit
ElseIf rng(i) < Goal Then
Answer = rng(i)
Answerlist = rng(i)
AnswerListPos = i
For j = i + 1 To UBound(rng)
If Answer + rng(j) = Goal Then
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
GoTo SubExit
ElseIf Answer + rng(j) < Goal Then
Answer = Answer + rng(j)
LastAdded = j
If Answerlist = "" Then
Answerlist = rng(j)
AnswerListPos = j
Else
Answerlist = Answerlist & "," & rng(j)
AnswerListPos = AnswerListPos & "," & j
End If
End If
If j = UBound(rng) Then
If LastAdded = UBound(rng) Then
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
Answer = Answer - rng(j)
LastAdded = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
End If
If LastAdded > 0 Then Answer = Answer - rng(LastAdded)
If InStr(Answerlist, ",") = 0 Then Exit For
j = Val(Mid(AnswerListPos, InStrRev(AnswerListPos, ",") + 1))
Answerlist = Left(Answerlist, InStrRev(Answerlist, ",") - 1)
AnswerListPos = Left(AnswerListPos, InStrRev(AnswerListPos, ",") - 1)
End If
Next j
End If
Answerlist = ""
Next i
SubExit:
If Answerlist <> "" Then
SumSolver = Answerlist
Else
SumSolver = "N/A"
End If
End Function
示例：
我决定更新我的速度测试。这次将更新后的代码与我的原始代码进行比较，并惊讶地发现了差异。我运行了 1000 次迭代，求解器找不到组合。我在屏幕更新的情况下做到了这一点。对于 8 个列表，最多有 255 个组合，对于 12 个列表，最多有 4095 个组合（添加每个项目时加倍）。对于 12 个列表，计算量为 4,095,000 次。更新后的代码平均耗时 13.6 秒。显然这是在我的机器上，结果与你的不同（但比率应该大致相同）。