求单元格内数值凑数函数或VBA

地主老财

各位坛友

本人想写一个函数或VBA来进行凑数，论坛上的递归VBA我也看了，没有弄明白，想请精通的坛友帮忙！
非常非常感谢！
附件是用office365做的 求单元格内数值凑数函数或VBA.zip (8.84 KB, 下载次数: 16)

2024-5-24 11:02 上传

点击文件名下载附件

caffish

光看你这一圈结果完全不知道你想要啥，比如，工程1里，为什么只有这四种组合，小于6000的可能性绝对不止4种，你要准确描述你的需求才有可能得到有效的帮助！

MR_PP

1. Sub MakeUpNumbers()
   
2. Dim TargetNumber As Double
   
3. Dim Numbers As Variant
   
4. Dim OutputRow As Integer
   
5. Dim RequiredCombinations As Integer
   
6. 
   
7. ' 设置目标数值
   
8. TargetNumber = 6000
   
9. 
   
10. ' 初始化数字数组
    
11. Numbers = Array(1354.5, 1486, 1643.7, 1821, 2053, 3255, 3679, 3832)
    
12. 
    
13. ' 计算所需的组合数量
    
14. RequiredCombinations = WorksheetFunction.RoundUp((1354.5 + 1486 + 1643.7 + 1821 + 2053 + 3255 + 3679 + 3832) / 6000, 0)
    
15. 
    
16. ' 初始化输出行
    
17. OutputRow = 1
    
18. 
    
19. ' 调用函数生成数字组合
    
20. FindNumbers TargetNumber, Numbers, OutputRow, RequiredCombinations
    
21. End Sub
    
22. 
    
23. Sub FindNumbers(Target As Double, Numbers As Variant, OutputRow As Integer, RequiredCombinations As Integer)
    
24. Dim i As Integer, j As Integer, k As Integer
    
25. Dim totalNumbers As Integer
    
26. Dim totalCombinations As Integer
    
27. Dim sum As Double
    
28. Dim combination As String
    
29. Dim count As Integer
    
30. Dim usedNumbers As String
    
31. Dim closestSum As Double
    
32. Dim closestCombination As String
    
33. Dim closestDiff As Double
    
34. Dim foundCombinations As Integer
    
35. 
    
36. closestSum = 0
    
37. closestCombination = ""
    
38. closestDiff = Target
    
39. foundCombinations = 0
    
40. 
    
41. totalNumbers = UBound(Numbers) - LBound(Numbers) + 1
    
42. totalCombinations = 2 ^ totalNumbers
    
43. 
    
44. For i = 1 To totalCombinations - 1
    
45. sum = 0
    
46. combination = ""
    
47. count = 0
    
48. usedNumbers = ""
    
49. 
    
50. For j = 0 To totalNumbers - 1
    
51.     If ((i And (2 ^ j)) <> 0) Then
    
52.         If InStr(usedNumbers, CStr(Numbers(LBound(Numbers) + j))) = 0 Then
    
53.             sum = sum + Numbers(LBound(Numbers) + j)
    
54.             combination = combination & Numbers(LBound(Numbers) + j) & "+"
    
55.             count = count + 1
    
56.             usedNumbers = usedNumbers & CStr(Numbers(LBound(Numbers) + j)) & ","
    
57.         End If
    
58.     End If
    
59. Next j
    
60. 
    
61. If count >= 2 And sum <= Target Then
    
62.     combination = Left(combination, Len(combination) - 1) ' 移除最后一个加号
    
63.     If Abs(Target - sum) <= closestDiff Then
    
64.         closestSum = sum
    
65.         closestCombination = combination
    
66.         closestDiff = Abs(Target - sum)
    
67.         If Abs(Target - sum) < closestDiff Then
    
68.             foundCombinations = 1
    
69.         ElseIf Abs(Target - sum) = closestDiff Then
    
70.             foundCombinations = foundCombinations + 1
    
71.         End If
    
72.         Worksheets("Sheet1").Cells(OutputRow, 3).Value = closestCombination
    
73.         OutputRow = OutputRow + 1
    
74.     End If
    
75. End If
    
76. 
    
77. If foundCombinations >= RequiredCombinations Then
    
78.     Exit For
    
79. End If
    
80. Next i
    
81. 
    
82. If foundCombinations = 0 Then
    
83. MsgBox "未找到符合条件的数字组合。"
    
84. Else
    
85. MsgBox "找到 " & foundCombinations & " 个组合，组合已成功写入C列"
    
86. End If
    
87. End Sub
    

复制代码

用GPT生成的代码，没用递归，供参考吧