跟踪更改 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 的工作表，其中记录了轨道变化。三列：

username (Environ("Username")) A 列，B 列中的日期和 C 列中的时间。

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

'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