Excel VBA腳本真的很慢

Question

我的腳本需要幾年才能運行嗎？這只是代碼的一部分，但它是降低速度的一部分。表格報告是來自電子病人系統的報告。它包含訪問日期，這些日期需要與工作表PtLog中的日期進行比較。在PtLog中，每行是一名患者，對於表格報告每次訪問都是一條線。因此，患者可以在工作表報告中的多行。有11個可能的訪問日期和約700名可能的患者。含義約7700日期需要檢查。我希望我自己有點清楚...提​​前

THX

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

For colPtLog = 11 To 20 

    For rowPtLog = 2 To lastRowUsedPtLog 

     Sheets("PtLog").Select 
     patientNrPtLog = Cells(rowPtLog, 5).Value 
     nrVisitPtLog = Cells(1, colPtLog).Value 
     dateVisitPtLog = Cells(rowPtLog, colPtLog).Value 

     Sheets("Report").Select 

     For rowReport = 2 To lastRowUsedReport 

      Sheets("Report").Select 
      dateVisitReport = Sheets("Report").Cells(rowReport, 6) 
      patientNrReport = Sheets("Report").Cells(rowReport, 2) 
      nrVisitReport = Sheets("Report").Cells(rowReport, 4) 


      If patientNrPtLog = patientNrReport And nrVisitPtLog = nrVisitReport Then 

       If dateVisitPtLog <> dateVisitReport Then 

        If dateVisitPtLog > 0 And dateVisitReport = 0 Then 

         Sheets("CONTROL").Select 
         lastRowUsedControlVisitNoDate = lastRowUsedControlVisitNoDate + 1 
         Cells(lastRowUsedControlVisitNoDate, 2) = patientNrPtLog 
         Cells(lastRowUsedControlVisitNoDate, 3) = nrVisitPtLog 

        End If 


        If dateVisitPtLog = 0 And dateVisitReport > 0 Then 

         Sheets("PtLog").Cells(rowPtLog, colPtLog) = dateVisitReport 
         With Sheets("PtLog").Cells(rowPtLog, colPtLog).Font 
          .Color = -1003520 
          .TintAndShade = 0 
         End With 

        End If 


        If dateVisitPtLog > 0 And dateVisitReport > 0 Then 

         Sheets("CONTROL").Select 
         lastRowUsedControlDateNoMatch = lastRowUsedControlDateNoMatch + 1 
         Cells(lastRowUsedControlDateNoMatch, 9) = patientNrPtLog 
         Cells(lastRowUsedControlDateNoMatch, 10) = nrVisitPtLog 
         Cells(lastRowUsedControlDateNoMatch, 11) = dateVisitReport 
         Cells(lastRowUsedControlDateNoMatch, 12) = dateVisitPtLog 

        End If 

       End If 

       Exit For 

      End If 

     Next rowReport 

    Next rowPtLog 

Next colPtLog 

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

Answer 1

我覺得OP代碼的實際緩慢是由於無用循環

這裏有相同的結果，OP的一個代碼，但循環通過只在必要時細胞

Option Explicit 

Sub SubMine() 
Dim lastRowUsedPtLog As Long, lastRowUsedReport As Long 
Dim lastRowUsedControlVisitNoDate As Long, lastRowUsedControlDateNoMatch As Long 

Dim ptLogDdateVisit As Long 
Dim reportPatientNr As Long, reportNrVisit As Long, reportDateVisit As Long 

Dim reportSht As Worksheet, ptLogSht As Worksheet, controlSht As Worksheet 

Dim ptLogPatientNrs As Range, ptLogPatientNrCells As Range, ptLogPatientNrCell As Range 
Dim ptLogVisitNrs As Range, ptLogNrVisitCell As Range, ptLogDateVisitCell As Range 
Dim reportPatientNrs As Range, reportPatientNrCell As Range 
Dim ptLogCellsToMark As Range 


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

Set reportSht = Sheets("Report") 
Set ptLogSht = Sheets("PtLog") 
Set controlSht = Sheets("CONTROL") 

' to avoid first "Union()" method call to fail, I set a dummy ptLogCellsToMark 
With ptLogSht 
    Set ptLogCellsToMark = .Cells(1, .Columns.Count) 
End With 

lastRowUsedPtLog = GetLastRow(ptLogSht, 5) 
lastRowUsedReport = GetLastRow(reportSht, 2) 
lastRowUsedControlVisitNoDate = GetLastRow(controlSht, 2) 
lastRowUsedControlDateNoMatch = GetLastRow(controlSht, 9) 

Set ptLogPatientNrs = ptLogSht.Cells(2, 5).Resize(lastRowUsedPtLog) 'list of PatientNr in "PtLog" sheet 
Set ptLogVisitNrs = ptLogSht.Range("K1:T1") 'list of VisitNr in "PtLog" sheet 
Set reportPatientNrs = reportSht.Cells(2, 2).Resize(lastRowUsedReport) 'list of PatientNr in "Report" sheet 

For Each reportPatientNrCell In reportPatientNrs 'loop through PatientNr of "Report" Sheet 

    reportPatientNr = reportPatientNrCell.Value ' track patientNr value from "Report" sheet 
    Set ptLogPatientNrCells = FindValues(reportPatientNr, ptLogPatientNrs) ' find ALL occurencies of that patientNr value in "PtLog" sheet 
    If Not ptLogPatientNrCells Is Nothing Then ' if there's an occurrence of that patientNr in "PtLog" sheet 

     reportNrVisit = reportPatientNrCell.Offset(, 2) ' now it makes sense to track nrVisit value from "Report" sheet 
     Set ptLogNrVisitCell = ptLogVisitNrs.Find(reportNrVisit) ' search for that nrVisit value in "PtLog" sheet 
     If Not ptLogNrVisitCell Is Nothing Then ' if there's an occurrence of that nrVisit value in "PtLog" sheet 

      reportDateVisit = reportPatientNrCell.Offset(, 4) ' now it makes sense to track dateVisit value from "Report" sheet 

      For Each ptLogPatientNrCell In ptLogPatientNrCells 'loop through ALL occurencies of report patientNr of "PtLog" Sheet 

       Set ptLogDateVisitCell = ptLogSht.Cells(ptLogPatientNrCell.Row, ptLogNrVisitCell.column) 'set the "PtLog" sheet cell with the date corresponding to patientNr and nrVisit from "report" sheet 
       ptLogDdateVisit = ptLogDateVisitCell.Value 

       Select Case True 
        Case ptLogDdateVisit > 0 And reportDateVisit = 0 
         lastRowUsedControlVisitNoDate = lastRowUsedControlVisitNoDate + 1 
         controlSht.Cells(lastRowUsedControlVisitNoDate, 2).Resize(, 3) = Array(reportPatientNr, reportNrVisit, ptLogDdateVisit) ' write in "CONTROL" sheet . NOTE: I added "ptLogDdateVisit" to keep track of what was date was not peresent in "Report" sheet 

        Case ptLogDdateVisit = 0 And reportDateVisit > 0 
         With ptLogDateVisitCell 
          .Value = reportDateVisit 'correct the "PtLog" sheet date value with the "Report" sheet one 
          Set ptLogCellsToMark = Union(ptLogCellsToMark, .Cells(1, 1)) ' add this cell to those that will be formatted at the end 
         End With 

        Case Else 
         lastRowUsedControlDateNoMatch = lastRowUsedControlDateNoMatch + 1 
         controlSht.Cells(lastRowUsedControlDateNoMatch, 9).Resize(, 4) = Array(reportPatientNr, reportNrVisit, reportDateVisit, ptLogDdateVisit) ' write in "CONTROL" sheet 
       End Select 

      Next ptLogPatientNrCell 

     Else 

      ' here code to handle what to do when a nrVist in "Report" sheet is not present in "PtLog" sheet 

     End If 


    Else 

     ' here code to handle what to do when a patientNr in "Report" sheet is not present in "PtLog" sheet 

    End If 

Next reportPatientNrCell 

With ptLogCellsToMark.Font 
    .Color = -1003520 
    .TintAndShade = 0 
End With 


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

End Sub 


Function FindValues(valueToFind As Variant, rngToSearchIn As Range) As Range 
Dim cell As Range, unionRng As Range 
Dim firstAddress As String 

With rngToSearchIn 
    Set cell = .Find(What:=valueToFind, LookAt:=xlWhole) 
    If Not cell Is Nothing Then 
     firstAddress = cell.Address 
     Set unionRng = cell 
     Do 
      Set unionRng = Union(unionRng, cell) 

      Set cell = .FindNext(cell) 
     Loop While Not cell Is Nothing And cell.Address <> firstAddress 
     Set FindValues = unionRng 
    End If 
End With 

End Function 


Function GetLastRow(sht As Worksheet, column As Long) As Long 
With sht 
    GetLastRow = .Cells(.Rows.Count, column).End(xlUp).Row 
End With 
End Function 

Answer 2

有幾件事情可以做，以提高你的代碼：

（1）不要選擇在你的代碼表而是直接將值分配給變量。因此，而不是：

Sheets("PtLog").Select 
patientNrPtLog = Cells(rowPtLog, 5).Value 
nrVisitPtLog = Cells(1, colPtLog).Value 
dateVisitPtLog = Cells(rowPtLog, colPtLog).Value 

你應該試試這個：

With Sheets("PtLog") 
    patientNrPtLog = .Cells(rowPtLog, 5).Value 
    nrVisitPtLog = .Cells(1, colPtLog).Value 
    dateVisitPtLog = .Cells(rowPtLog, colPtLog).Value 
End With 

（2）不要使用.Value而是.Value2如果可能的話。因此，對於上面的代碼片段，這意味着您可以進一步改進代碼，如下所示。

With Sheets("PtLog") 
    patientNrPtLog = .Cells(rowPtLog, 5).Value2 
    nrVisitPtLog = .Cells(1, colPtLog).Value2 
    dateVisitPtLog = .Cells(rowPtLog, colPtLog).Value2 
End With 

（3）聲明您在代碼中使用的所有變量。如果你沒有聲明變量，那麼VBA將自動假設這些變量是variant，這是性能最差的。所以，你應該寫（以前所有Sub S）以下行：

Option Explicit 

而且在你的子，你應該聲明所有變量。這裏有些例子。

Dim rowPtLog As Long 
Dim lastRowUsedReport As Long 
Dim dateVisitPtLog As Date 
Dim dateVisitReport As Date 

（4）當你寫回表，那麼你也應該明確寫出要對.Value2分配給小區。所以，與其

Sheets("PtLog").Cells(rowPtLog, colPtLog) 

你應該寫

Sheets("PtLog").Cells(rowPtLog, colPtLog).Value2 

。注意，VBA/Excel是非常快的，在內存中處理數據。但是將數據寫回到工作表會減慢代碼速度。嘗試限制這些行（如果可能的話）。

（5）確保lastRowUsedPtLog和lastRowUsedReport不是太高。這是兩個內部循環。所以，如果第一個數字很大（5位或更多），而第二個數字也很大，那麼這很容易導致數百萬次的迭代，這也會減慢你的代碼速度。

（6）如果可能，跳過行。如果上述循環無法避免，那麼您應該嘗試跳過不需要處理的行。例如，如果第5列中沒有patientNrPtLog，那麼可能不需要經過這一行。因此，如果需要，您可以包含另一個if..then以僅處理該行或者另外跳過該行。

以上幾點應該已經讓你開始了。讓我們知道事後會如何改進，並且還可能在代碼中實現時間跟蹤器，以查看最大時間損失在哪裏。可以這樣做，像這樣：

Dim dttProcedureStartTime As Date 
dttProcedureStartTime = Now() 

之後，您可以跟蹤與代碼行這樣的時間：

Debug.Print Now() - dttProcedureStartTime 

也許這樣你可以找出最大的「時間loosers」。