[已解决]代码提速

乐乐2006201506

各位老师，附件中代码可以实现e3单元格输入数字（1,2,3……），f4中用公式取得棱长为e3中数值的正方体表面积，然后运行代码（按钮1），即可得出表面积为f4中值的所有正方体（长方体）的棱长（长宽高）的数据，但是该代码在数值比较大的情况下，比如棱长20时，正方体表面积为2400，循环时非常耗时。同时，如果代码改进并提速后，我想实现循环赋值给S，让自动算出指定范围内的长宽高（这个要求我自己也可以用循环实现）。
也可以用另外的思路另写代码。
在此先谢谢了。

最佳答案

月排行榜 / 总排行榜

grf1973

2017-3-27 20:26

忘记提交代码了。

1. Sub test1()
   
2.     Dim s, i&, j&, k, v, ar(1 To 65536, 1 To 5), n&
   
3.     Application.DisplayAlerts = False
   
4.     s = Range("f4").Value
   
5.     If s Mod 2 = 1 Then MsgBox "无整数解": Exit Sub
   
6.     s = s / 2         'i * j + i * k + j * k=s/2 必须为整数
   
7.     For i = 1 To s / 2          '当j=1，k=1时，i有最大值s/2
   
8.         For j = 1 To s / 2         '当i=1，k=1时，j有最大值s/2
   
9.             k = (s - i * j) / (i + j)    '根据 i * j + i * k + j * k=s ，求出k
   
10.             If k < 1 Then Exit For  '如果k出现负值，退出循环
    
11.             If k = Int(k) Then '如果k为正整数
    
12.                 n = n + 1
    
13.                 ar(n, 1) = i
    
14.                 ar(n, 2) = j
    
15.                 ar(n, 3) = k
    
16.                 ar(n, 4) = i * j * k
    
17.                 ar(n, 5) = s * 2
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     [H:L].ClearContents
    
22.     [H1].Resize(1, 5) = Array("长", "宽", "高", "体积", "表面积")
    
23.     [H2].Resize(n, 5) = ar
    
24.     Application.DisplayAlerts = True
    
25. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub test1()
   
2.     Dim s, i&, j&, k, v, ar(1 To 65536, 1 To 5), n&
   
3.     Application.DisplayAlerts = False
   
4.     s = Range("f4").Value
   
5.     If s Mod 2 = 1 Then MsgBox "无整数解": Exit Sub
   
6.     s = s / 2         'i * j + i * k + j * k=s/2 必须为整数
   
7.     For i = 1 To s / 2          '当j=1，k=1时，i有最大值s/2
   
8.         For j = 1 To s / 2         '当i=1，k=1时，j有最大值s/2
   
9.             k = (s - i * j) / (i + j)    '根据 i * j + i * k + j * k=s ，求出k
   
10.             If k >= 1 And k = Int(k) Then   '如果k为正整数
    
11.                 n = n + 1
    
12.                 ar(n, 1) = i
    
13.                 ar(n, 2) = j
    
14.                 ar(n, 3) = k
    
15.                 ar(n, 4) = i * j * k
    
16.                 ar(n, 5) = s * 2
    
17.             End If
    
18.         Next j
    
19.     Next i
    
20.     [H:L].ClearContents
    
21.     [H1].Resize(1, 5) = Array("长", "宽", "高", "体积", "表面积")
    
22.     [H2].Resize(n, 5) = ar
    
23.     Application.DisplayAlerts = True
    
24. End Sub

复制代码

grf1973

还可以再提速。

grf1973

忘记提交代码了。

1. Sub test1()
   
2.     Dim s, i&, j&, k, v, ar(1 To 65536, 1 To 5), n&
   
3.     Application.DisplayAlerts = False
   
4.     s = Range("f4").Value
   
5.     If s Mod 2 = 1 Then MsgBox "无整数解": Exit Sub
   
6.     s = s / 2         'i * j + i * k + j * k=s/2 必须为整数
   
7.     For i = 1 To s / 2          '当j=1，k=1时，i有最大值s/2
   
8.         For j = 1 To s / 2         '当i=1，k=1时，j有最大值s/2
   
9.             k = (s - i * j) / (i + j)    '根据 i * j + i * k + j * k=s ，求出k
   
10.             If k < 1 Then Exit For  '如果k出现负值，退出循环
    
11.             If k = Int(k) Then '如果k为正整数
    
12.                 n = n + 1
    
13.                 ar(n, 1) = i
    
14.                 ar(n, 2) = j
    
15.                 ar(n, 3) = k
    
16.                 ar(n, 4) = i * j * k
    
17.                 ar(n, 5) = s * 2
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     [H:L].ClearContents
    
22.     [H1].Resize(1, 5) = Array("长", "宽", "高", "体积", "表面积")
    
23.     [H2].Resize(n, 5) = ar
    
24.     Application.DisplayAlerts = True
    
25. End Sub

复制代码

大灰狼1976

棱长20时提速至7秒左右，还可以优化。

1. Sub test()
   
2. Dim s, L&, i&, j&, k&, v, ar(1 To 65536, 1 To 5), n&
   
3. s = Range("f4").Value
   
4. If s / 2 = Int(s / 2) Then L = s / 8 Else L = s / 4
   
5.         For i = 1 To L
   
6.             For j = 1 To L
   
7.                 For k = 1 To L
   
8.                     If (i * j + i * k + j * k) * 2 = s Then
   
9.                         n = n + 1
   
10.                         ar(n, 1) = i
    
11.                         ar(n, 2) = j
    
12.                         ar(n, 3) = k
    
13.                         ar(n, 4) = i * j * k
    
14.                         ar(n, 5) = s
    
15.                     End If
    
16.                 Next k
    
17.             Next j
    
18.         Next i
    
19.         m = Range("h65536").End(3).Row + 1
    
20.         Range("h" & m).Resize(n, 5) = ar
    
21. End Sub

复制代码

大灰狼1976

菱长20控制在1秒以内，实际结果组数减少了，但是有效组数是正确的，因为大部分都是重复值。
实际上不重复值只有23组，但生成了101组，还有很大的提升空间。

1. Sub test()
   
2. Dim s, L&, i&, j&, k&, v, ar(1 To 65536, 1 To 5), n&
   
3. s = Range("f4").Value
   
4. If s / 2 = Int(s / 2) Then L = s / 8 Else L = s / 4
   
5.         For i = 1 To L
   
6.             For j = 1 To IIf(s > 600, L / 3, L)
   
7.                 For k = 1 To IIf(s > 600, L / 3, L)
   
8.                     If (i * j + i * k + j * k) * 2 = s Then
   
9.                         n = n + 1
   
10.                         ar(n, 1) = i
    
11.                         ar(n, 2) = j
    
12.                         ar(n, 3) = k
    
13.                         ar(n, 4) = i * j * k
    
14.                         ar(n, 5) = s
    
15.                     End If
    
16.                 Next k
    
17.             Next j
    
18.         Next i
    
19.         m = Range("h65536").End(3).Row + 1
    
20.         Range("h" & m).Resize(n, 5) = ar
    
21. End Sub

复制代码

大灰狼1976

没关系，本来我的答案也不是最好的。

乐乐2006201506

大灰狼1976 发表于 2017-3-28 14:22
没关系，本来我的答案也不是最好的。

谢谢您的大度和包容！

大灰狼1976

实际上我现在棱长30时运算时间已可压缩至0.07秒，但是还是比楼上高手的代码慢了许多。
但是还有提高余地。

乐乐2006201506

大灰狼1976 发表于 2017-3-28 16:09
实际上我现在棱长30时运算时间已可压缩至0.07秒，但是还是比楼上高手的代码慢了许多。
但是还有提高余地。

1000时，楼上代码10秒过一点。