Question

我有一个问题，我一直试图解决。我正在尝试构建一个宏，当某些单元格（E5，E8，E10，E12）在Sheet1中更新并且文件也被保存（两个标准都要满足）时，我希望在工作表中创建一个时间戳（“日期”））使用用户名（Environ（“用户名”））列A，列B中的日期和列C中的时间。

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

我从这里开始。

Function LastSavedTimeStamp()
 LastSavedTimeStamp = ActiveWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function

=IF((WEEKNUM(A2,2)=WEEKNUM(B2,2)),"yes","no")

Answer 1

这应该可以解决问题。将所有这些放在ThisWorkbook

中

'set as public variables to remain saved while workbook is open
Public val1, val2, val3, val4

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("Sheet1").Range("E5").Value
val2 = Sheets("Sheet1").Range("E8").Value
val3 = Sheets("Sheet1").Range("E10").Value
val4 = Sheets("Sheet1").Range("E12").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("Sheet1")
Set wsDates = ThisWorkbook.Sheets("Dates")

'if the values have been changed
If _
val1 <> ws.Range("E5").Value Or _
val2 <> ws.Range("E8").Value Or _
val3 <> ws.Range("E10").Value Or _
val4 <> ws.Range("E12").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 = Environ("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

就不同周的可能性而言，测试有点困难，但我认为它应该有效。

编辑：此版本通过使用几个数组来处理要检查的大量单个单元格。和以前一样，把它放在ThisWorkbook中你应该很好。

'set as global variables to remain saved while workbook is open
Option Explicit
Private val() As Variant, rng() As Variant

Private Sub Workbook_Open()
'define which cells to check
rng = Array("D20", "D24", "D25", "D27", "D28", "D30", "D31", "D32", "D33", "D34", "D35", "D37", "D38", "D40", "D42", "D43", "D44", "D54", "D55", "D56", "D58", "D59", "D61", "D62", "D63", "D64", "D65", "E20", "E24", "E25", "E27", "E28", "E30", "E31", "E32", "E33", "E34", "E35", "E37", "E38", "E40", "E42", "E43", "E44", "E54", "E55", "E56", "E58", "E59", "E61", "E62", "E63", "E64", "E65")

'redefine the val array to match the size of the rng array (necessary)
ReDim val(53) As Variant

'set the variables when the workbook is opened
Call SetValues
End Sub

Private Sub SetValues()
Dim x As Long
'save the values to be checked later
For x = LBound(rng()) To UBound(rng())
    val(x) = Sheets("Sheet3").Range(rng(x)).Value
Next x
End Sub

Private Function ValuesChanged() As Boolean
Dim x As Long
'check the values
For x = LBound(rng()) To UBound(rng())
    If val(x) <> Sheets("Sheet3").Range(rng(x)).Value Then
        ValuesChanged = True
        Exit Function
    End If
Next x
End Function

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 ValuesChanged 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 = Environ("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

时间戳和日期记录

1 个答案: