楼主
liuguansky |
Q：如何通过配码比例和总和来求得所有配码？
效果如下图：
A:用如下代码可以实现：- Sub justtest()
- Dim arr, i%, arrt(), s%, k%, dic As New dictionary'定义变量，定义字典对象，需在VBE下工具－引用－mscripting.runtime
- Dim dic1 As New dictionary, d, m%, n%, j As Boolean
- If Application.Sum([b3:h3]) = 1 Then'判断比例和是否为1，如果为1，则进行下面的判断。
- arr = [b3:h3*12]'获取初始比例与和值12的乘积，赋值给数组。
- For i = 1 To 7'在数组中循环
- If Int(arr(i)) = arr(i) Then
- s = arr(i) + s'如果为整，则累加
- Else: dic.Add i, Int(arr(i)): s = s + Int(arr(i))'不为整，则添加字典项目，同时累加整数部分。为后续服务
- End If
- Next i
- k = Application.WorksheetFunction.Combin(dic.Count, 12 - s)'返回所有组合数。
- '组合思路：DIC.COUNT代表非整数的个数，12-S代表可以分配的个数。就是把12-S个数分配到DIC.COUNT个地方，所以个数为Combin(dic.Count, 12 - s)
- Cells(8, 1) = "订货配码": Range("b8:h" & Rows.Count).Clear'清空配码返回区域，方便返回，清除干扰。
- If k = 1 Then'如果只有一种配码方式，则全是整数，
- Cells(8, 2).Resize(1, 7) = arr'直接返回之前赋值整数数组即可。
- MsgBox "共1种方案,见区域" & Cells(8, 2).Resize(1, 7).Address(0, 0)'友好提示配码的方案数，与返回配码的对应区域。
- Else:如果不只一种方案，则：
- Do Until m = k'循环到，出现K种方案为止。
- str1 = ""
- For Each d In dic.keys'这里用随机数方式来生成K种方案。
- j = Rnd() >= 0.5'把随机判断赋值给一个BOOLEAN类型的变量
- If j Then arr(d) = dic(d) Else arr(d) = dic(d) + 1'如果J真，则取整，如果假，则取整+1
- str1 = str1 & arr(d)同时把相应的值进行组合，用于判断是否重复。
- Next d
- If Application.Sum(arr) = 12 Then'当和值达到12，才是满足的配码方式：
- If Not dic1.exists(str1) Then dic1.Add str1, arr: m = m + 1'如果字典项目中不存在，则说明为新的配码方式，于是添加项目，同时对ITEM赋值满足条件的数组。并且计数加1，此计数再与总配码方式K相比例，当随机循环达到K值时，即停止循环
- End If
- Loop
- ReDim arrt(1 To k, 1 To 7)'重定义数组，用于返回目标配码方案
- For i = 1 To k
- For m = 1 To 7
- arrt(i, m) = dic1.Items(i - 1)(m)'数组对数组赋值，用循环实现 。
- Next m, i
- Cells(8, 2).Resize(k, 7) = arrt'对配码返回区域赋值。
- MsgBox "共" & k & "种方案,见区域" & Cells(8, 2).Resize(k, 7).Address(0, 0)'友好提示方案种数，并提示配码方案返回区域。
- End If
- Else: MsgBox "请确认输入的销售比例是否正确！"'不为1，则友好提示重新录入销售比例。
- End If
- End Sub
具体示例文件如下：
|