VBA代码效率跟踪变化

我的下面的代码运作良好，我的问题是，我的范围现在已经扩大 ，我需要一个更有效的方法来处理它。

代码更新我的date工作表，当下面的范围已经更新和文件也保存（这两个条件需要满足）。 有什么build议？

（D）（D）（20,24,25,27,28,30,31,32,33,34,35,37,38,40,42,43,44,54,55,56,58,59,61 ，62,63,64,65）

（第23,24,25,27,28,30,31,32,33,34,35,37,38,40,42,43,44,54,55,56,58,59,61号） ，62,63,64,65）

'set as public variables to remain saved while workbook is open Public val1, val2, val3, val4, Val5 Private Sub Workbook_Open() 'set the variables when the workbook is opened Call SetValues End Sub Private Sub SetValues() 'save the values to be checked later val1 = Sheets("Sheet3").Range("D20").Value val2 = Sheets("Sheet3").Range("D24").Value val3 = Sheets("Sheet3").Range("D25").Value val4 = Sheets("Sheet3").Range("D27").Value Val5 = Sheets("Sheet3").Range("D28").Value End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim ws As Worksheet, wsDates As Worksheet Dim endRow As Long, updateRow As Long, x As Long Dim checkDate Set ws = ThisWorkbook.Sheets("Sheet3") Set wsDates = ThisWorkbook.Sheets("Dates") 'if the values have been changed If _ val1 <> ws.Range("D20").Value Or _ val2 <> ws.Range("D24").Value Or _ val3 <> ws.Range("D25").Value Or _ val4 <> ws.Range("D27").Value Or _ Val5 <> ws.Range("D28").Value Then 'reset the values to avoid multiple updates Call SetValues 'set the range of values to check endRow = wsDates.Cells(wsDates.Rows.Count, 1).End(xlUp).Row 'check to see if an entry was found the same week For x = 1 To endRow checkDate = wsDates.Cells(x, 2).Value If checkDate >= (Date - Weekday(Date, vbSunday) + 1) And checkDate <= (Date - Weekday(Date, vbSaturday) + 1 + 7) Then updateRow = x Exit For End If Next x 'if an entry the same week wasn't found, set update row to new row If updateRow = 0 Then updateRow = endRow + 1 'update or add information wsDates.Cells(updateRow, 1).Formula = Application.UserName wsDates.Cells(updateRow, 2).Formula = Format(Now, "mm/dd/yyyy") wsDates.Cells(updateRow, 3).Formula = Format(Now, "HH:mm:ss") End If End Sub