[已解决]代码提速

大灰狼1976

你指的1000是棱长吗？10秒确定？你是什么配置的电脑？
我现在的代码已经比楼上快了，最后发现思路甚至结构都基本一致，
但是我在Lmax上下了点功夫，棱长100时在我的破电脑上跑0.078秒，生成结果249组，
有效结果（不重复）131组。楼上高手的代码在同样的条件下跑0.20秒，生成结果739组，
有效结果（不重复）同样也是131组。

1. Sub test()
   
2. Dim s&, L&, Lmax&, L1&, L2&, arr(1 To 65536, 1 To 5), n&, m
   
3. t = Timer
   
4. s = [f4]
   
5. L = [e4]
   
6. [H2].CurrentRegion.ClearContents
   
7. If L Mod 2 = 0 Then Lmax = s / 8 Else Lmax = s / 4
   
8. s = s / 2
   
9. For L1 = 1 To L
   
10.   For L2 = L To Lmax
    
11.     m = (s - L1 * L2) / (L1 + L2)
    
12.     If m < 1 Then Exit For
    
13.     If m = Int(m) Then
    
14.       n = n + 1
    
15.       arr(n, 1) = L1
    
16.       arr(n, 2) = L2
    
17.       arr(n, 3) = m
    
18.       arr(n, 4) = L1 * L2 * m
    
19.       arr(n, 5) = s * 2
    
20.     End If
    
21.   Next L2
    
22. Next L1
    
23. [H2].Resize(n, 5) = arr
    
24. MsgBox Timer - t
    
25. End Sub

复制代码

大灰狼1976

既然有重复结果，说明还有提升空间，这个题很有意思，我会继续研究下去。

大灰狼1976

好吧，仔细看了下代码，与高手的代码接近99%的相似度，可以认为我抄袭吧，懒得解释

乐乐2006201506

没有这个意思，为您的执着精神点赞，如有更好的方法，希望分享，另外，只要在别人代码基础上改进也是一种能力啊！

电脑在76%情况下的速度，我试试您的代码，等会儿告诉您速度。




这个是您的最新代码的速度。提速近3倍。和您测试（0.078,0.2）的差不多。

您这个棱长2000时，内存占用78%时，16秒多。期待您更好的代码。

16楼代码和本楼代码速度基本一样。您说的提速25%，估计是和您没有重复代码比较的结果吧！

大灰狼1976

已经可以生成不重复结果，但是时间反而变长了，我还要再优化。

大灰狼1976

现在又提速25%左右，可以生成不重复结果。
但是总感觉不精妙，还要再研究。

1. Sub test()
   
2. Dim s&, L&, Lmax&, L1&, L2&, arr(1 To 65536, 1 To 5), n&, m
   
3. s = [f4]
   
4. L = [e4]
   
5. [H2].CurrentRegion.ClearContents
   
6. If L Mod 2 = 0 Then Lmax = s / 8 Else Lmax = s / 4
   
7. s = s / 2
   
8. For L1 = 1 To L
   
9.   For L2 = L To Lmax
   
10.     m = (s - L1 * L2) / (L1 + L2)
    
11.     If m < 1 Then Exit For
    
12.     If m = Int(m) Then
    
13.       If m >= L1 And m <= L2 Then
    
14.         n = n + 1
    
15.         arr(n, 1) = L1
    
16.         arr(n, 2) = L2
    
17.         arr(n, 3) = m
    
18.         arr(n, 4) = L1 * L2 * m
    
19.         arr(n, 5) = s * 2
    
20.       End If
    
21.     End If
    
22.   Next L2
    
23. Next L1
    
24. [H2].Resize(n, 5) = arr
    
25. End Sub

复制代码

大灰狼1976

你再试试，L2动态化了，取消Lmax，结果无重复。
Sub test()
Dim s&, L&, L1&, L2&, arr(1 To 65536, 1 To 5), n&, m, a&
t = Timer
s = [f4]
L = [e4]
[H2].CurrentRegion.ClearContents
s = s / 2
For L1 = 1 To L
  a = (s - L1) / (L1 + 1)
  For L2 = L To a
    m = (s - L1 * L2) / (L1 + L2)
    If m = Int(m) Then
      If m >= L1 And m <= L2 Then
        n = n + 1
        arr(n, 1) = L1
        arr(n, 2) = L2
        arr(n, 3) = m
        arr(n, 4) = L1 * L2 * m
        arr(n, 5) = s * 2
      End If
    End If
  Next L2
Next L1
[H2].Resize(n, 5) = arr
MsgBox Timer - t
End Sub

乐乐2006201506

大灰狼1976 发表于 2017-3-29 10:31
你再试试，L2动态化了，取消Lmax，结果无重复。
Sub test()
Dim s&, L&, L1&, L2&, arr(1 To 65536, 1 To ...

您最新代码，棱长1000时，最快2.72秒。
非常感谢！
敬业精神，钻研精神，都是我学习的楷模。

grf1973

原来代码小改一下，棱长1000，运行0.5秒，还加上了排序。

1. Sub grf()
   
2.     t1 = Timer
   
3.     Dim s, i, j, k, v, ar(1 To 65536, 1 To 5), n&
   
4.     Application.DisplayAlerts = False
   
5.     s = Range("f4").Value
   
6.     If s Mod 2 = 1 Then MsgBox "无整数解": Exit Sub
   
7.     s = s / 2         'i * j + i * k + j * k=s/2 必须为整数
   
8.     '不失一般性，令k>=j>=i (k,j,i分别为长，宽，高）
   
9.     For i = 1 To s / 2 - 1        '当j=1，k=1时，i有最大值s/2
   
10.         For j = i To s / 2         '当i=1，k=1时，j有最大值s/2
    
11.             k = (s - i * j) / (i + j)    '根据 i * j + i * k + j * k=s ，求出k
    
12.             If k < j Then Exit For  '如果k出现负值，退出循环
    
13.             If k = Int(k) Then '如果k为正整数
    
14.                 n = n + 1
    
15.                 ar(n, 1) = k
    
16.                 ar(n, 2) = j
    
17.                 ar(n, 3) = i
    
18.                 ar(n, 4) = i * j * k
    
19.                 ar(n, 5) = s * 2
    
20.             End If
    
21.         Next j
    
22.     Next i
    
23.     [H:L].ClearContents
    
24.     [H1].Resize(1, 5) = Array("长", "宽", "高", "体积", "表面积")
    
25.     [H2].Resize(n, 5) = ar
    
26.     [H2].Resize(n, 5).Sort key1:=[H2], key2:=[i2], key3:=[j2]    '排序
    
27.     Application.DisplayAlerts = True
    
28.     MsgBox "运行时间" & Timer - t1 & "秒，不重复解共" & n & "组"
    
29. End Sub
    

复制代码

grf1973

基本只改动了第10句和第12句。