VBA代码优化 ( 恳求算法高手 )

On_fire

VBA 代码优化( 恳求算法高手)

*

https://club.excelhome.net/thread-1601369-1-1.html

这是以前的请求需求

感恩褚老师的热心帮忙,完美解决了问题!

*

现在的问题,是效率及速度问题!

可能现在的矩阵数据太多 ( 行列太多 ),

当执行代码时, 都是假死的情况, 超过...10分钟或以上!

*

恳请算法高手能出手帮忙...看看有甚么方法, 可以优化?

ahnyt

褚老师的速度应该就不慢了

On_fire

ahnyt 发表于 2021-10-24 12:50
褚老师的速度应该就不慢了

我肯定知道褚老师绝对是大神级的!

当执行一次代码, 结果完美!
但是, 也超过10分钟或以上..

naroto

你这个还是要问褚老师。没有谁好意思超过大神级的。

naroto

看你发了200+的主题，应该是开发程序的吧？

zpy2

没看明白是派啥用的啊？

yjh_27

On_fire 发表于 2021-10-24 12:55
我肯定知道褚老师绝对是大神级的!

当执行一次代码, 结果完美!

试试

1. Sub test1()
   
2.   Dim r%, i%, j%, c%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a1").Resize(r, c)
   
8.   End With
   
9.   ReDim brr(1 To UBound(arr), 1 To UBound(arr))
   
10.   For i = 1 To UBound(arr)
    
11.     brr(i, 1) = arr(i, 1)
    
12.     brr(1, i) = arr(i, 1)
    
13.   Next
    
14.   For i = 2 To UBound(arr)
    
15.       brr(i, i) = 1
    
16.       For j = i + 1 To UBound(arr)
    
17.         For k = 2 To UBound(arr, 2)
    
18.           brr(i, j) = brr(i, j) + Application.Min(arr(i, k), arr(j, k))
    
19.         Next
    
20.         If brr(i, j) = 0 Then brr(i, j) = Empty
    
21.         brr(j, i) = brr(i, j)
    
22.       Next
    
23.   Next
    
24.   With Worksheets("rows")
    
25.     .Cells.Clear
    
26.     .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
27.   End With
    
28. End Sub
    

复制代码

芐雨

1. Sub TestRows()
   
2.     Dim r%, i%, j%, c%
   
3.     Dim arr, brr
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.    
   
8.     Dim tim1 As Date, tim2 As Date: tim1 = Timer
   
9.    
   
10.     With Worksheets("sheet1")
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
13.         arr = .Range("a1").Resize(r, c)
    
14.     End With
    
15.     ReDim brr(1 To UBound(arr), 1 To UBound(arr))
    
16.     For i = 1 To UBound(arr)
    
17.         brr(1, i) = arr(i, 1)
    
18.         brr(i, 1) = arr(i, 1)
    
19.         brr(i, i) = 1
    
20.     Next
    
21.     brr(1, 1) = Empty
    
22.    
    
23.     For i = 2 To UBound(arr) - 1
    
24.         For j = 2 To UBound(arr, 2)
    
25.             If arr(i, j) <> "" Then
    
26.                 For ii = i + 1 To UBound(arr)
    
27.                     If arr(ii, j) <> "" Then
    
28.                         If arr(i, j) < arr(ii, j) Then
    
29.                             brr(i, ii) = brr(i, ii) + arr(i, j)
    
30.                         Else
    
31.                              brr(i, ii) = brr(i, ii) + arr(ii, j)
    
32.                         End If
    
33.                         
    
34.                         brr(ii, i) = brr(i, ii)
    
35.                     End If
    
36.                 Next
    
37.                
    
38.             End If
    
39.             
    
40.         Next
    
41.         
    
42.     Next
    
43.    
    
44.     With Worksheets("rows")
    
45.         .Cells.Clear
    
46.         .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
47.     End With
    
48.    
    
49.     Application.DisplayAlerts = True
    
50.     Application.ScreenUpdating = True
    
51.     tim2 = Timer
    
52.     MsgBox Format(tim2 - tim1, "程序执行时间为：0.000秒"), 64, "时间统计"
    
53. End Sub
    

复制代码

On_fire

naroto 发表于 2021-10-24 13:54
看你发了200+的主题，应该是开发程序的吧？

肯定不是, 我这水平去做开发程序, 真是太搞笑了...

On_fire

yjh_27 发表于 2021-10-24 18:04
试试

谢谢老师,
您的代码快了约1倍左右, 用了4-5分钟