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”。