[已解决]VBA代码的优化

安全网

将使用在未完成（1）和未完成（2）表内所使用的VBA代码优化，缩短宏运行的时间。

最佳答案

月排行榜 / 总排行榜

grf1973

2015-10-26 13:34

1. Sub TEST()
   
2.     Application.ScreenUpdating = False
   
3.     Dim X, Y, M, N, L, ARR, ARR1(1 To 30000, 1 To 23), ARR2(1 To 30000, 1 To 23)
   
4.     Dim WB As Workbook
   
5.     Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
   
6.     Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
   
7.     ARR = WB.Sheets(1).Range("A3:W" & Y)
   
8.     For X = 1 To UBound(ARR, 1)
   
9.        If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
   
10.             M = M + 1
    
11.          For Y = 1 To UBound(ARR, 2)
    
12.             ARR1(M, Y) = ARR(X, Y)
    
13.          Next Y
    
14.        End If
    
15.       
    
16.         If (ARR(X, 15) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 22) = "" And ARR(X, 4) <> "" Then
    
17.             N = N + 1
    
18.          For Y = 1 To UBound(ARR, 2)
    
19.             ARR2(N, Y) = ARR(X, Y)
    
20.          Next Y
    
21.        End If
    
22.     Next X
    
23.     WB.Close True
    
24.     Set WB = Nothing
    
25.    
    
26.     With ThisWorkbook
    
27.         .Sheets(1).Range("A2:W" & Y).Clear
    
28.         If M > 0 Then .Sheets(1).Range("A2").Resize(M, 23) = ARR1
    
29.         .Sheets(1).Range("A2:W" & M + 1).Borders.LineStyle = xlContinuous
    
30.         
    
31.         .Sheets(2).Range("A2:W" & Y).Clear
    
32.         If N > 0 Then .Sheets(2).Range("A2").Resize(N, 14) = ARR2
    
33.         .Sheets(2).Range("A2:N" & N + 1).Borders.LineStyle = xlContinuous
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub TEST()
   
2.     Application.ScreenUpdating = False
   
3.     Dim X, Y, M, N, L, ARR, ARR1(1 To 30000, 1 To 23), ARR2(1 To 30000, 1 To 23)
   
4.     Dim WB As Workbook
   
5.     Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
   
6.     Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
   
7.     ARR = WB.Sheets(1).Range("A3:W" & Y)
   
8.     For X = 1 To UBound(ARR, 1)
   
9.        If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
   
10.             M = M + 1
    
11.          For Y = 1 To UBound(ARR, 2)
    
12.             ARR1(M, Y) = ARR(X, Y)
    
13.          Next Y
    
14.        End If
    
15.       
    
16.         If (ARR(X, 15) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 22) = "" And ARR(X, 4) <> "" Then
    
17.             N = N + 1
    
18.          For Y = 1 To UBound(ARR, 2)
    
19.             ARR2(N, Y) = ARR(X, Y)
    
20.          Next Y
    
21.        End If
    
22.     Next X
    
23.     WB.Close True
    
24.     Set WB = Nothing
    
25.    
    
26.     With ThisWorkbook
    
27.         .Sheets(1).Range("A2:W" & Y).Clear
    
28.         If M > 0 Then .Sheets(1).Range("A2").Resize(M, 23) = ARR1
    
29.         .Sheets(1).Range("A2:W" & M + 1).Borders.LineStyle = xlContinuous
    
30.         
    
31.         .Sheets(2).Range("A2:W" & Y).Clear
    
32.         If N > 0 Then .Sheets(2).Range("A2").Resize(N, 14) = ARR2
    
33.         .Sheets(2).Range("A2:N" & N + 1).Borders.LineStyle = xlContinuous
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36. End Sub

复制代码