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 当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

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

1 个答案: