Wie beschleunige ich meine Codeausführung?

Question

Ich habe eine Routine, die sehr gut funktioniert. Das einzige Problem ist, dass die Ausführung zu lange dauert. Können Sie Vorschläge machen, wie Sie es beschleunigen können? Ich denke, eine Möglichkeit besteht darin, Werte direkt Bereichen zuzuordnen, anstatt das Blatt auszuwählen und dann das Objekt activesheet zu verwenden.

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

Nur einige der obigen Ausführungen zusammenfassen:

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. Unnötige Dim (weil nicht in der Unter verwendet) entfernt wurden.
2. Deaktivieren Sie ScreenUpdating, Calculation und Events.
3. Entfernen Sie alle .Select (bis auf die letzte).
4. Zusammenfassen mehrerer Schritte.
5. Mit .Value2 statt .Value