求整数拆分组合

tianmashi

香川群子 发表于 2012-3-23 16:53
请看附件。

由于文件和代码中使用了范围名称，所以需要使用我的附件。

群子老师，感谢您的帮助，您的解答很独特很厉害，我想将数据扩展，应该怎么改呢？您再帮我看看，附件如下：

香川群子

tianmashi 发表于 2012-3-23 21:00
群子老师，感谢您的帮助，您的解答很独特很厉害，我想将数据扩展，应该怎么改呢？您再帮我看看，附件如下 ...

原来的代码直接可用……

不过，既然只要第4表结果，那么前面多余的可以删掉了。

Table2.rar (161.14 KB, 下载次数: 90)

2012-3-24 15:49 上传

点击文件名下载附件

1. Sub test()
   
2.     rw = Cells(65536, Range("data").Column).End(3).Row + 1
   
3.     cl = Range("data").End(2).Column - Range("data").Column
   
4.     arr = [b2].Resize(rw, cl)
   
5.    
   
6.     n = Cells(65536, Range("input").Column + 1).End(3).Row - 1
   
7.     brr = Range("input").Offset(1, 1).Resize(n, 2)
   
8.    
   
9.     ReDim crr(cl * 3 * 39, (rw / 3 - 1) \ 39)
   
10.     ReDim k((rw / 3 - 1) \ 39)
    
11.    
    
12.     For i = 1 To n
    
13.         x = Val(brr(i, 1)) - 1
    
14.         y = Val(brr(i, 2))
    
15.         
    
16.         j = x \ 39
    
17.         crr(k(j), j) = arr(x * 3 + 1, y)
    
18.         crr(k(j) + 1, j) = arr(x * 3 + 2, y)
    
19.         k(j) = k(j) + 3
    
20.         
    
21.     Next
    
22.    
    
23.     t = Application.Large(k, 1)
    
24.     Range("output").Offset(1, 1).Resize(t, UBound(crr, 2) + 1) = crr
    
25. End Sub
    

复制代码

香川群子

任意整料分割的附件例子。

xd3210

经典方案，很实用！

香川群子

以此代码为基础，帮别人解决了多元一次方程组整数解的问题：

http://club.excelhome.net/thread-1099141-1-1.html

香川群子

写了个递归计算按系数拆分整数求全部组合解的代码。

可以用来处理解多元一次方程组全部组合解：

1. Dim sj, jg(), h&, h2&, k&, l&, m&, n&, n2&, r1&, cnt&
   
2. Sub kagawa_11() '整数拆分
   
3.     tms = Timer
   
4.     m = [a1].End(4).Row: [a1].Resize(m).Sort [a1], 1, , , 2: sj = [a1].Resize(m)
   
5.     h = [b1]: h2 = [b2]: If h2 >= h Then h2 = h2 - h
   
6.     n = [b4]: n2 = [b5]: If n2 = 0 Then If n = 0 Then n2 = m Else n2 = n
   
7.     r1 = [b3]: l = [b6]: If l = 0 Then l = 65536
   
8.     ReDim jg(l, 3): jg(0, 0) = "h": jg(0, 1) = "f": jg(0, 2) = "n": jg(0, 3) = "f1"
   
9.     k = 0: cnt = 0: Call dgH11(h, "", "", m, 0): [b7] = k: [b8] = cnt
   
10.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & cnt
    
11.     If k Then [f1].CurrentRegion = "": [f1].Resize(k + 1, 4) = jg: [f1].CurrentRegion.AutoFilter Field:=1
    
12. End Sub
    
13. Sub dgH11(r&, s1$, s2$, i&, t&)
    
14.     Dim j&, h1&, rs$, t1&, t2&
    
15.     cnt = cnt + 1
    
16.    
    
17.     t1 = sj(i, 1)
    
18.     If i = 1 Then
    
19.         For j = IIf(r < t1, 0, r \ t1) To (r + h2 - 1) \ t1 + 1
    
20.             If j Then rs = "+" & t1 & "*" & j & s1 Else rs = s1
    
21.             If j = 0 Or (j And j > r1) Then
    
22.                 h1 = Application.Evaluate(rs)
    
23.                 If h <= h1 And h1 <= h + h2 Then
    
24.                     t2 = IIf(j, t + 1, t)
    
25.                     If n <= t2 And t2 <= n2 Then
    
26.                         k = k + 1
    
27.                         jg(k, 0) = h1
    
28.                         jg(k, 1) = "+" & t1 & "*" & j & s2
    
29.                         jg(k, 2) = t2
    
30.                         jg(k, 3) = rs
    
31.                     End If
    
32.                 End If
    
33.             End If
    
34.         Next
    
35.         Exit Sub
    
36.     End If
    
37.    
    
38.     Call dgH11(r, s1, "+" & t1 & "*0" & s2, i - 1, t)
    
39.     For j = r1 + 1 To (r + h2 - 1) \ t1 + 1
    
40.         Call dgH11(r - t1 * j, IIf(j, "+" & t1 & "*" & j & s1, s1), "+" & t1 & "*" & j & s2, i - 1, IIf(j, t + 1, t))
    
41.     Next
    
42. End Sub
    

复制代码

northwolves

楼主可搜索“母函数”

香川群子

上个求 【多元一次方程 非负整数解】 的实用附件。

chaucerwong

香川群子老师真厉害，很实用

香川群子

整数拆分的递归算法，更快更简洁：

原始数据升序排列在A列，目标值范围在B1、B2

1. Dim sj&(), jg(), h1&, h2&, k&, m&, n1&, n2&, tms#, cnt&
   
2. Sub kagawa_12() '整数拆分&#8658;不定方程整数係数解
   
3.     Dim i&, l&
   
4.     tms = Timer
   
5.     [c:c] = "": [c1] = "目標和h": [c2] = "和上限h2": [c5] = "個数n": [c6] = "個数n2→": [c7] = "求解数l": [c8] = "結果k": [c9] = "計算cnt": [c10] = "計算時": [c11] = "総耗時"
   
6.    
   
7.     h1 = [b1]: h2 = [b2]: If h2 Then h1 = h2 - h1 Else h2 = h1: h1 = 0
   
8.     m = [a1].End(4).Row: n1 = [b5]: n2 = [b6]: If n2 = 0 Then If n1 = 0 Then n2 = m Else n2 = n1
   
9.     ReDim sj(m)
   
10.     For i = 1 To m
    
11.         sj(i) = Cells(i, 1)
    
12.     Next
    
13.    
    
14.     l = [b7]: If l Then ReDim jg(l, 2) Else ReDim jg(65530, 2): jg(0, 0) = "h": jg(0, 1) = "n": jg(0, 2) = "f"
    
15.     Application.EnableCancelKey = xlErrorHandler
    
16.     On Error GoTo Err_Handler
    
17.     k = 0: cnt = 0: Call dgH12("", h2, m, 1)
    
18. Err_Handler:
    
19.     [b8] = k: [b9] = cnt: [b10] = Format(Timer - tms, "0.000")
    
20.     Application.StatusBar = Format(Timer - tms, "0.000s ") & k & "/" & cnt
    
21.     [f1].CurrentRegion = "": [f1].Resize(k + 1, 3) = jg: [f1].CurrentRegion.AutoFilter Field:=1
    
22.     [b11] = Format(Timer - tms, "0.000")
    
23. End Sub
    
24. Sub dgH12(r$, h&, i&, t&)
    
25.     Dim a&, j&, n&
    
26.     cnt = cnt + 1
    
27.     If cnt Mod 10000 = 0 Then Application.StatusBar = Format(Timer - tms, "0.000s ") & k & "/" & cnt & "..." & Left(r, 180)
    
28.     For n = i To 2 Step -1
    
29.         a = sj(n)
    
30.         For j = h \ a To 1 Step -1
    
31.             If j * a >= (h - h1) Then
    
32.                 If t >= n1 Then
    
33.                     k = k + 1: jg(k, 1) = t: jg(k, 0) = h2 - h + j * a
    
34.                     jg(k, 2) = "+" & j & "*" & a & r
    
35.                 End If
    
36.             End If
    
37.             If t < n2 Then Call dgH12("+" & j & "*" & a & r, h - j * a, n - 1, t + 1)
    
38.         Next
    
39.     Next
    
40.     If t >= n1 Then
    
41.         a = sj(1)
    
42.         For j = IIf(h > h1, -Int((h1 - h) / a), 1) To h \ a
    
43.             k = k + 1: jg(k, 1) = t: jg(k, 0) = h2 - h + j * a
    
44.             jg(k, 2) = "+" & j & "*" & a & r
    
45.         Next
    
46.     End If
    
47. End Sub
    

复制代码