如何改善這段程式，讓執行效率提升？

av8d

1. Sub test()
   
2. '年度分析，開銷前3名
   
3.     Application.ScreenUpdating = False
   
4.     W = [W]
   
5.     r = [A1].CurrentRegion.Rows.Count
   
6.     Range("B7:M" & r).ClearContents
   
7.     Range("B2:M3").ClearContents
   
8.     myyear = [A1].Value
   
9.     For c = 2 To 13
   
10.         mymonth = myyear & "/" & Trim(Cells(1, c).Value)
    
11.         income = 0
    
12.         expense = 0
    
13.         pay = 0
    
14.         v = 11
    
15.         With Sheets("DataCopy")
    
16.             er = .[A100000].End(3).Row
    
17.             For r = 2 To er
    
18.                 If myyear & "/" & Format(.Cells(r, 1).Value, "m月份") = mymonth Then
    
19.                     money = Val(.Cells(r, 3).Value)
    
20.                     Select Case .Cells(r, 2).Value
    
21.                         Case "收入": income = income + money
    
22.                         Case "支出": expense = expense + money
    
23.                         Case "分期付款": expense = expense + money: pay = pay + 1
    
24.                     End Select
    
25.                     myitem = .Cells(r, 4).Value
    
26.                     If .Cells(r, 2).Value <> "收入" Then
    
27.                         Set cell = Columns(c + 1).Find(myitem)
    
28.                         If Not cell Is Nothing Then
    
29.                             cell.Offset(, -1).Value = cell.Offset(, -1).Value + money
    
30.                         Else
    
31.                             Cells(v, c).Value = money
    
32.                             Cells(v, c + 1).Value = .Cells(r, 4).Value
    
33.                             v = v + 1
    
34.                         End If
    
35.                     End If
    
36.                 End If
    
37.             Next r
    
38.             If Cells(11, c) <> "" Then
    
39.                 Set rng = Range(Cells(11, c), Cells(v - 1, c + 1))
    
40.                 rng.Sort key1:=Cells(11, c), order1:=xlDescending
    
41.                 X = 0
    
42.                 v = 11
    
43.                 Do Until Cells(v, c).Value = ""
    
44.                     If InStr(W, Cells(v, c + 1)) = 0 Then
    
45.                         If X < 3 Then
    
46.                             X = X + 1
    
47.                             Cells(X + 6, c).Value = X & ". " & Cells(v, c + 1).Value & " / " & Cells(v, c).Value & "元"
    
48.                         End If
    
49.                     End If
    
50.                     Cells(v, c).Value = v - 10 & ". " & Cells(v, c + 1).Value & " / " & Cells(v, c).Value & "元"
    
51.                     Cells(v, c + 1).Value = ""
    
52.                     v = v + 1
    
53.                 Loop
    
54.             End If
    
55.         End With
    
56.         Cells(2, c).Value = IIf(income <> 0, income, "")
    
57.         Cells(3, c).Value = IIf(expense <> 0, expense, "")
    
58.         Cells(10, c).Value = pay
    
59.     Next c
    
60.     Application.ScreenUpdating = True
    
61. '自動換行
    
62.     Rows("7:100000").EntireRow.AutoFit
    
63.     Application.ScreenUpdating = True
    
64. End Sub

複製代碼

以上是某位老師撰寫，有點忘了是誰(失禮了)，原本都用XP的Excel執行，效率都還OK，
換成2010後，執行以後會變得非常非常的慢，不知道有沒有辦法改善，謝謝！

PKKO

回復 1# av8d


    流程的部分我沒有分析,但我確定的是可以用陣列會執行的更快
因為陣列的運作速度會比讀取CELLS快N倍

在開頭的地方先
AR=[a1].currentregion'此行風險在於中斷的儲存格,若有中斷的儲存格請用下方
AR=[a1].resize(x,y)'可自訂陣列大小
之後AR(1,1) 就會等於 cells(1,1)=>因此將程式碼取代即可,  而.value的部分則可刪除

with 的部分一樣用AR2=.[a1].currentregion'即可,AR2(1,1)=.cells(1,1)
但後面sort的部分要保留原本的CELLS才不會有問題
以及最後輸出的.cells.value因為要輸出,當然不可取代為陣列