跟踪更改VBA代码 - 如何重写此代码？

Question

问题：我的问题是我如何扩大我的范围应用下面的范围。如果我应用所有范围，代码将变得太长。我正在寻找更有效的写作方式。

我试图将宏应用于我的项目，该项目跟踪更改，一旦单元格下面的区域发生更改并保存文件（两个条件都会被满足）。我试图让代码更加动态和高效（更短）。

我的范围： Sheet3.Range 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）

Sheet3.Range E（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）

我有一个叫做Dates的工作表，其中记录了轨道变化。三列：

用户名（ENVIRON（ “用户名”））塔A中，在日期栏B和时间列C.

问题2 当表Sheet 3细胞是以后更新。我需要使用新的附加行更新工作表（“日期”）中的信息，但是如果这个新日期与已经存在的日期在同一周发生，那么它应该更新该行。所以我试图避免在同一周内保存日期。目标是记录任务每周最后一次完成的时间

'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 

Answer 1

这就是我如何构造这个任务的代码。

Private Sub Workbook_Open() 
     'set the variables when the workbook is opened 
     GetValues True 
    End Sub 

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 
     ' 02 Sep 2017 

     If HasChanges Then 
      WriteLog 
      'reset the values to avoid multiple updates 
      GetValues True 
     End If 
    End Sub 

    Private Function HasChanges() As Boolean 
     ' 02 Sep 2017 

     Dim Prev As Variant, Curr As Variant 
     Dim R As Long, C As Long 
     Dim i As Long 

     Prev = GetValues 
     Curr = CheckRange.Value 
     For i = LBound(Prev) To UBound(Prev) 
      For C = LBound(Prev, 2) To UBound(Prev, 2) 
       If Curr(i, C) <> Prev(i, C) Then 
        R = i + AllRows(0) - LBound(Prev) 
        If Not IsError(Application.Match(R, AllRows, 0)) Then 
         HasChanges = True 
         Exit Function 
        End If 
       End If 
      Next C 
     Next i 
    End Function 

    Private Sub WriteLog() 
     ' 02 Sep 2017 

     Dim WsDates As Worksheet 
     Dim checkDate 
     Dim endRow As Long, updateRow As Long 
     Dim R As Long 

     With WsDates 
      endRow = .Cells(.Rows.Count, 1).End(xlUp).Row 
      'check to see if an entry was found the same week 
      For R = 1 To endRow 
       checkDate = .Cells(R, 2).Value 
       If (checkDate >= (Date - Weekday(Date, vbSunday) + 1)) And _ 
        (checkDate <= (Date - Weekday(Date, vbSaturday) + 1 + 7)) Then 
        Exit For 
       End If 
      Next R 

      'if an entry the same week wasn't found, set update row to new row 
      updateRow = R 

      'update or add information 
      With .Rows(updateRow) 
       .Cells(1).Formula = Application.UserName 
       .Cells(2).Formula = Format(Now, "mm/dd/yyyy") 
       .Cells(3).Formula = Format(Now, "HH:mm:ss") 
      End With 
     End With 
    End Sub 

    Private Function GetValues(Optional ByVal ResetValues As Boolean) As Variant 
     ' 02 Sep 2017 

     ' if called without parameters, this function returns the value last set 
     ' if called with ResetValues = True or if never called during current session 
      ' it returns the current values 

     Static Fun As Variant 
     Dim Rng As Range 

     If ResetValues Or (VarType(Fun) = 0) Then Fun = CheckRange.Value 
     GetValues = Fun 
    End Function 

    Private Function AllRows() As Variant 
     ' 02 Sep 2017 

     AllRows = Array(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) 
    End Function 

    Private Function CheckRange() As Range 
     ' 02 Sep 2017 

     With Worksheets("Sheet3") 
      Set CheckRange = .Range(.Cells(AllRows(0), "D"), _ 
            .Cells(AllRows(UBound(AllRows)), "E")) 
     End With 
    End Function