Excel VBA脚本真的很慢
为什么我的脚本需要很长时间才能运行？ 这只是代码的一部分，但它是减慢速度的部分。 表格报告是来自电子病人系统的报告。 它包含访问date，这些date需要与PtLog表单中的date进行比较。 在PtLog中，每一行是一个病人，至于表单报告每一次访问是一条线。 所以病人可以在工作表报告中的几行。 有11个可能的访问date和约700名可能的病人。 含义约7700date需要检查。 我希望我自己有些清楚
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 我认为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
有几件事你可以做，以改善你的代码：
（1）不要在代码中select表单，而是直接将值分配给variables。 所以，而不是：
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）声明你在代码中使用的所有variables。 如果你没有声明variables，那么VBA会自动假定variables是variablestypes，这是性能最差的。 所以，你应该写下（ 在所有Sub 之前 ）以下行：
Option Explicit
而在你的分区你应该声明所有的variables。 这里有些例子。
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
也许这样，你可以确定最大的“时间宽松”。