如何加快我的代码执行速度？

Question

我有一个很好的例程。唯一的问题是执行时间太长。你能提出如何加速的建议吗？我认为一种方法是我直接将值赋给范围，而不是选择工作表，然后使用activesheet对象。

Sub calculate() 

Dim rng1 As Range 
Dim lastCell As Range 
Dim starFill As Range 
'Dim LastCellRowNumber As Long 
Dim strFind As String 
Dim rng2 As Range 
strFind = "***" 
Dim clearFormat As Range 
Dim demand As Range 
Dim demandFill As Range 
Dim supply As Range 
Dim supplyFill As Range 
Dim delta As Range 
Dim deltaFill As Range 
Dim i As Integer 
Dim j As Integer 
Dim rng3 As Range 
Dim rng4 As Range 
Dim lasteCell2 As Range 
Dim rng5 As Range 
Dim rng6 As Range 
Dim mon As Range 
Dim k As Integer 



'save month values from resource plan for use in dashboard 
Worksheets("Resource Plan").Columns("D:D").EntireColumn.Hidden = False 
For j = 1 To 6 
Worksheets("Resource Plan").Select 
Set mon = ActiveSheet.Cells(2, (j + 9)) 

For k = 1 To 29 
Select Case k 
Case 5, 11, 17, 23, 29 
Worksheets("Dashboard").Select 
Worksheets("Dashboard").Cells(k, (j + 3)).Value = mon 
Case Else 
End Select 
Next k 
Next j 


'calculate demand 
Worksheets("Resource Plan").Select 

Set rng4 = ActiveSheet.Columns("D").Find(strFind, , xlValues, xlWhole) 
    rng4.Select 
    Set lastCell2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, (4)).End(xlUp) 
    Set rng5 = Range(rng4, lastCell2) 
    Set rng5 = rng5.Offset(0, 0).Resize(rng5.Rows.Count - 1) 
For i = 0 To 29 
    Worksheets("Resource Plan").Select 
    Set rng1 = ActiveSheet.Columns("J").Find(strFind, , xlValues, xlWhole) 
    Set lastCell = ActiveSheet.Cells(ActiveSheet.Rows.Count, (10)).End(xlUp) 
    Set rng2 = Range(rng1, lastCell) 
    Set rng2 = rng2.Offset(4, i).Resize(rng2.Rows.Count - 5, rng2.Columns.Count) 
    rng2.Select 
    Selection.Copy 
    Worksheets("Sheet1").Select 
    Range("A1").Select 
    ActiveSheet.Paste 
    Application.CutCopyMode = False 
    Set rng3 = Sheets("Sheet1").Cells(1, 3) 
    rng3.Select 
    Selection.Copy 
    Worksheets("Results").Select 
    Cells(18, (i + 7)).Select 
    Selection.PasteSpecial Paste:=xlValues 
Next i 
Worksheets("Resource Plan").Select 
Columns("D:D").EntireColumn.Hidden = True 
Cells(1, 1).Select 


'Worksheets("Dashboard").Select 

End Sub 

Answer 1

只是为了总结上面的一些评论：

Option Explicit 

Sub calculate() 

Dim rng1 As Range 
Dim lastCell As Range 
Dim strFind As String 
Dim rng2 As Range 
strFind = "***" 
Dim i As Integer 
Dim j As Integer 
Dim rng3 As Range 
Dim rng4 As Range 
Dim lastCell2 As Range 
Dim rng5 As Range 
Dim k As Integer 

With Application 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
    .EnableEvents = False 
End With 

With Worksheets("Resource Plan") 

    'save month values from resource plan for use in dashboard 
    .Columns("D:D").EntireColumn.Hidden = False 
    For j = 1 To 6 
     For k = 1 To 29 
      Select Case k 
       Case 5, 11, 17, 23, 29 
        Worksheets("Dashboard").Cells(k, (j + 3)).Value2 = .Cells(2, (j + 9)).Value2 
       Case Else 
      End Select 
     Next k 
    Next j 

    'calculate demand 
    Set rng4 = .Columns("D").Find(strFind, , xlValues, xlWhole) 
    Set lastCell2 = .Cells(.Rows.Count, (4)).End(xlUp) 
    Set rng5 = .Range(rng4, lastCell2) 
    Set rng5 = rng5.Offset(0, 0).Resize(rng5.Rows.Count - 1) 
    For i = 0 To 29 
     Set rng1 = .Columns("J").Find(strFind, , xlValues, xlWhole) 
     Set lastCell = .Cells(.Rows.Count, (10)).End(xlUp) 
     Set rng2 = Range(rng1, lastCell) 
     Set rng2 = rng2.Offset(4, i).Resize(rng2.Rows.Count - 5, rng2.Columns.Count) 
     rng2.Copy Destination:=Worksheets("Sheet1").Range("A1") 
     Set rng3 = Sheets("Sheet1").Cells(1, 3) 
     Worksheets("Results").Cells(18, (i + 7)).Value2 = rng3.Value2 
    Next i 
    .Columns("D:D").EntireColumn.Hidden = True 
    .Activate 
    .Cells(1, 1).Select 
End With 

'Worksheets("Dashboard").Select 

With Application 
    .ScreenUpdating = True 
    .Calculation = xlCalculationAutomatic 
    .EnableEvents = True 
End With 

End Sub 

1. 不必要Dim（因为个子不使用）已被删除。
2. 禁用ScreenUpdating，Calcultion和Events。
3. 删除全部.Select（最后一个除外）。
4. 总结几个步骤。
5. 使用的.Value2代替.Value