[已解决]请高手优化VBA代码

wszsp

我的VBA代码效率不高，速度太慢，请高手

优化VBA提高效率和速度

具体见附件

最佳答案

月排行榜 / 总排行榜

grf1973

2017-11-2 21:09

确实太慢了。居然全部复制了再删除。。。。。

1. Sub grf()
   
2.   Set d = CreateObject("scripting.dictionary")
   
3.   Dim bt As Range, sh As Worksheet
   
4.   Application.ScreenUpdating = False
   
5.   With Sheets(1)
   
6.     arr = .Range("B1:B" & .[b65536].End(3).Row)
   
7.     Set bt = .Range("a1:f1") '表头
   
8.     For i = 2 To UBound(arr)
   
9.         x = arr(i, 1)
   
10.         If x <> "" Then
    
11.             If Not d.exists(x) Then
    
12.                 Set d(x) = Union(bt, .Cells(i, 1).Resize(1, 6))
    
13.             Else
    
14.                 Set d(x) = Union(d(x), .Cells(i, 1).Resize(1, 6))
    
15.             End If
    
16.         End If
    
17.     Next
    
18. End With
    
19. 
    
20. Call 删除
    
21. For Each x In d.keys
    
22.     Application.StatusBar = x
    
23.     Sheets.Add after:=Sheets(Sheets.Count)
    
24.     ActiveSheet.Name = x
    
25.     d(x).Copy ActiveSheet.[a1]
    
26. Next
    
27. Sheets(1).Select
    
28. Application.ScreenUpdating = True
    
29. Application.StatusBar = False
    
30. End Sub
    
31. 
    
32. Sub 删除()
    
33.     Application.DisplayAlerts = False
    
34.     For Each sh In Worksheets
    
35.        If sh.Index > 1 Then sh.Delete
    
36.     Next
    
37.     Application.DisplayAlerts = True
    
38. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

确实太慢了。居然全部复制了再删除。。。。。

1. Sub grf()
   
2.   Set d = CreateObject("scripting.dictionary")
   
3.   Dim bt As Range, sh As Worksheet
   
4.   Application.ScreenUpdating = False
   
5.   With Sheets(1)
   
6.     arr = .Range("B1:B" & .[b65536].End(3).Row)
   
7.     Set bt = .Range("a1:f1") '表头
   
8.     For i = 2 To UBound(arr)
   
9.         x = arr(i, 1)
   
10.         If x <> "" Then
    
11.             If Not d.exists(x) Then
    
12.                 Set d(x) = Union(bt, .Cells(i, 1).Resize(1, 6))
    
13.             Else
    
14.                 Set d(x) = Union(d(x), .Cells(i, 1).Resize(1, 6))
    
15.             End If
    
16.         End If
    
17.     Next
    
18. End With
    
19. 
    
20. Call 删除
    
21. For Each x In d.keys
    
22.     Application.StatusBar = x
    
23.     Sheets.Add after:=Sheets(Sheets.Count)
    
24.     ActiveSheet.Name = x
    
25.     d(x).Copy ActiveSheet.[a1]
    
26. Next
    
27. Sheets(1).Select
    
28. Application.ScreenUpdating = True
    
29. Application.StatusBar = False
    
30. End Sub
    
31. 
    
32. Sub 删除()
    
33.     Application.DisplayAlerts = False
    
34.     For Each sh In Worksheets
    
35.        If sh.Index > 1 Then sh.Delete
    
36.     Next
    
37.     Application.DisplayAlerts = True
    
38. End Sub
    

复制代码

wszsp

grf1973 :

太谢谢你了，帮了大忙了。

不过，我想在sheet1前面再插入一个表格做汇总。就不行了，请帮助看看代码哪里再修改一下才行。