为什么我的脚本需要很长时间才能运行？这只是代码的一部分，但它是减慢它的部分。报告表是来自电子病人系统的报告。它包含访问日期，这些日期需要与工作表PtLog中的日期进行比较。在PtLog中，每一行都是一名患者，对于工作表报告，每次访问都是一行。因此患者可以在报告表中的几行。有11个可能的访问日期和约700个可能的患者。需要检查7700个日期的含义。我希望自己有点清楚......
事先提前 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
答案 0 :(得分：3)
您可以采取以下措施来改进代码：
（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
你的sub应该声明所有变量。以下是一些例子。
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
也许这样你可以找出最大的“时间宽松”。
答案 1 :(得分：0)
我认为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