使用 LastRow、Time Stamp 和 Workbook.sheetchange 使用 Excel VBA 创建数据历史记录

Question

我在 Excel VBA 中编写了一个手动宏，它显示一个表格，以显示名为“评估”的工作表中某些数据的历史记录。我引用的数据在“清单”表中。（如下所示）问题是“清单”中的数据每天或更频繁地变化。每次工作表更改时，宏都应在“评估”表的 LastRow 中插入一个带有新日期的新行。 （我用谷歌搜索，发现可以使用时间戳，见下文和函数 Workbook.Sheetchange，每次更改工作表时都应该激活这个宏，见下文）。我想在“评估”中显示数据的历史记录。所以最后一次更改的行中的值应该保持稳定。 因此，例如“评估”中的第 1 行：2020-01-17 值为 1（这应该保持为 1，因为我想查看进度） 现在工作表更改并插入第 2 行： 第 2 行：2020-01-18 值现在为 2（从清单复制），我希望第 1 行中的值保持为 1（因为在上次更改之前它是 1）。 现在它看起来像这样：

Sub Test()
'
' Test Macro
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "='checklist'!R[399]C[58]"
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "='checklist'!R[399]C[58]"

End Sub

时间戳：

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("'checklist'!BH400:BL500")) Is Nothing Then
      Cells(Target.Row, 1) = Format(Now, "DD/MM/YYYY  hh:mm")
   End If
End Sub

workbook.sheetchange：

Private Sub Workbook_SheetChange(ByVal Sh As Object, _ 
 ByVal Source As Range) 
 ' runs when a sheet is changed 
End Sub

您对如何连接这些代码有任何想法吗？对不起，我不是真正的 VBA 专家。我制作了一个谷歌表来显示我的实际意思，但我在 excel VBA 中需要这个，谷歌表只是为了形象化我的意思：https://docs.google.com/spreadsheets/d/1OU_95Lhf6p0ju2TLlz8xmTegHpzTYu4DW0_X57mObBc/edit#gid=0

这是我现在的代码：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
    If Sh.Name = "Checklist" Then
          'Monitoring from A3:E100, if different change this
          If Not Intersect(target, Range("A2:E1000")) Is Nothing Then
             'if any monitoring here, please you add here
             Test target 'Here procedure to insert
          End If
    End If
End Sub


Private Sub Test(target As Range)
    Dim LastRow As Long

    LastRow = Range("Evaluation!A" & Sheets("Evaluation").Rows.Count).End(xlUp).Row

    If Range("Evaluation!A1").Value <> "" Then
       LastRow = LastRow + 1
    End If
    'every change A3:E in checklist will insert row to this evaluation
    'but if different please you decide here
    Range("Evaluation!A" & LastRow).Value = Format(Now, "dd.mm.yyyy hh:mm") 'you can change this
    Range("Evaluation!B" & LastRow & ":F" & LastRow).Value = Range("Checklist!A" & target.Row & ":E" & target.Row).Value
End Sub

Answer 1

这里是你需要的代码

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
    If Sh.Name = "checklist" Then
          If Not Intersect(target, Range("BH400:BL500")) Is Nothing Then
             Cells(target.Row, 1) = Format(Now, "DD/MM/YYYY  hh:mm")
             Test target
          End If
    End If
End Sub

Private Sub Test(target As Range)
    Dim LastRow As Long

    LastRow = Range("evaluation!A" & Sheets("evaluation").Rows.Count).End(xlUp).Row

    If Range("evaluation!A1").Value <> "" Then
       LastRow = LastRow + 1
    End If
    Range("evaluation!A" +LastRow).Value = "=NOW()"
    Range("evaluation!B" +LastRow).Value = Range("CheckList!B" & Target.row)
    Range("evaluation!C" +LastRow).Value= "1"
    Range("evaluation!D" +LastRow).Value= Range("CheckList!D" & Target.row)
End Sub

更新为您的谷歌表格

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
    If Sh.Name = "CheckList" Then
          'Monitoring from A3:E100, if different change this
          If Not Intersect(target, Range("A3:E100")) Is Nothing Then
             'if any monitoring here, please you add here
             Test target 'Here procedure to insert
          End If
    End If
End Sub


Private Sub Test(target As Range)
    Dim LastRow As Long

    LastRow = Range("Evaluation!A" & Sheets("Evaluation").Rows.Count).End(xlUp).Row

    If Range("Evaluation!A1").Value <> "" Then
       LastRow = LastRow + 1
    End If
    'every change A3:E in checklist will insert row to this evaluation
    'but if different please you decide here
    Range("Evaluation!A" & LastRow).Value = Format(Now, "dd.mm.yyyy hh:mm") 'you can change this
    Range("Evaluation!B" & LastRow & ":F" & LastRow).Value = Range("CheckList!A" & target.Row & ":E" & target.Row).Value
End Sub

下次更新

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
    If Sh.Name = "CheckList" Then
          'Monitoring from A3:E100, if different change this
          If Not Intersect(target, Range("A3:E100")) Is Nothing Then
             'if any monitoring here, please you add here
             Test target 'Here procedure to insert
          End If
          If Not Intersect(target, Range("G3:K100")) Is Nothing Then
             'if any monitoring here, please you add here
             Test target 'Here procedure to insert
          End If
    End If
End Sub


Private Sub Test(target As Range)
    Dim LastRow As Long

    Dim myCol As Long
    myCol = target.Column

    If myCol >= 1 And myCol <= 5 Then
        LastRow = Range("Evaluation!A" & Sheets("Evaluation").Rows.Count).End(xlUp).Row

        If Range("Evaluation!A1").Value <> "" Then
           LastRow = LastRow + 1
        End If
        'every change A3:E in checklist will insert row to this evaluation
        'but if different please you decide here
        Range("Evaluation!A" & LastRow).Value = Format(Now, "dd.mm.yyyy hh:mm") 'you can change this
        Range("Evaluation!B" & LastRow & ":F" & LastRow).Value = Range("CheckList!A" & target.Row & ":E" & target.Row).Value
    End If
    If myCol >= 7 And myCol <= 11 Then
        LastRow = Range("Evaluation!H" & Sheets("Evaluation").Rows.Count).End(xlUp).Row

        If Range("Evaluation!H1").Value <> "" Then
           LastRow = LastRow + 1
        End If
        'every change A3:E in checklist will insert row to this evaluation
        'but if different please you decide here
        Range("Evaluation!H" & LastRow).Value = Format(Now, "dd.mm.yyyy hh:mm") 'you can change this
        Range("Evaluation!I" & LastRow & ":M" & LastRow).Value = Range("CheckList!G" & target.Row & ":K" & target.Row).Value
    End If
End Sub

Answer 2

这里监控CheckList!A1:H4并将CheckList!J3:N5完全复制到A列的Evaluation空行：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
    If Sh.Name = "CheckList" Then
          'Monitoring from CheckList!A1:H4, if different change this

          If Not Intersect(target, Range("CheckList!A1:H4")) Is Nothing Then
             Test target 'Here procedure to insert
          End If
    End If
End Sub


Private Sub Test(target As Range)
    Dim LastRow As Long

    Dim myCol As Long
    Dim myRow As Long
    myCol = target.Column

    If myCol >= 1 And myCol <= 8 Then
    If Range("Evaluation!A1") = "" Then Range("Evaluation!A1") = "History"
    If Range("Evaluation!A2") = "" Then Range("Evaluation!A2") = "Date"
        LastRow = Range("Evaluation!A" & Sheets("Evaluation").Rows.Count).End(xlUp).Row

        'In this situation, all J3 to N5 will be copied
        'if different, please modify as actual range
        Dim myRange As Range
        Set myRange = Range("CheckList!J3:N5")
        For a = 1 To myRange.Rows.Count
            LastRow = LastRow + 1
            Range("Evaluation!A" & LastRow).Value = Format(Now, "dd.mm.yyyy hh:mm")
            Range("Evaluation!B" & LastRow & ":F" & LastRow).Value = myRange.Rows(a).Value
        Next a
    End If
End Sub

Answer 3

你必须有通用模块（不是对象模块），如果没有，插入新模块，并把这个：

Public myLastRow As Long
Public myTarget As Long

Public Function CheckMe(target As Long)
    CheckMe = ""
    Range("Evaluation!A:F").UnMerge
    LastRow = Range("Evaluation!A" & Sheets("Evaluation").Rows.Count).End(xlUp).Row
    If Range("Evaluation!A1").Value <> "" Then
       LastRow = LastRow + 1
    End If
    myLastRow = LastRow
    myTarget = target
End Function

通过公式调用单元格G3中的函数：

=LEFT(A3&B3&C3&D3&E3&F3&CheckMe(ROW(A3)),0)

将单元格 G3 复制到 G4:G1000（或作为最后一行）

最后，在我们之前使用的 ThisWorkBook 模块中，清除所有代码，并添加此代码：

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    If myTarget < 3 Then Exit Sub
    Range("Evaluation!A:F").UnMerge

    Range("Evaluation!A" & myLastRow).Value = Format(Now, "dd.mm.yyyy hh:mm") 'you can change this
    Range("Evaluation!B" & myLastRow & ":F" & myLastRow).Value = Range("Checklist!A" & myTarget & ":E" & myTarget).Value
    myLastRow = 0
    myTarget = 0
End Sub

做测试