使用 Excel VBA 使用 LastRow、Time Stamp 和 Workbook.sheetchange 创

Question

我在Excel VBA中编程了一个手动宏，该宏显示一个表格，以在名为"评估"的工作表中显示某些数据的历史记录。我引用的数据在"清单"表中。(看下面(问题是"清单"中的数据每天都在变化或更频繁。每次工作表更改时，宏都应在"评估"中表格的最后一行中插入一行带有新日期的新行。(我用谷歌搜索了一下，我发现可以使用时间戳，见下文和函数 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

工作簿.工作表更改：

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

在这里监控清单！A1：H4 并复制清单！J3：N5 到 A 列的评估空行完全：

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(或作为最后一行(

最后，在我们之前使用的这个工作簿模块中，清除所有代码，并添加以下代码：

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

并进行测试