Creating a data history with Excel VBA using LastRow, Time Stamp and Workbook.sheetchange

问题

I have programmed a manual macro in Excel VBA that displays a table to show the history of certain data in a sheet called "evaluation". The data i reference to is in the table "checklist".(Look below) The problem is that the data in "checklist" changes every day or more often. Every time the sheet changes the macro should insert a new row with a new date into the LastRow of the table in "evaluation". (I googled and I found the possibility to use a Timestamp, see below and the function Workbook.Sheetchange, that should activate this macro every time the worksheet gets changed, see below). I would like to display a history of the data in "evaluation". So the values in the row of the last change should stay stable. So for example row 1 in "evaluation": 2020-01-17 value is 1 (this should stay 1, because i want to see the progress) Now the sheet changes and row 2 gets inserted: row 2: 2020-01-18 value is now 2 (copied from checklist) and i want the value in row 1 to stay at 1 (because it was 1 before the last change). Right now it looks like this:

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

timestamp:

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

Do you have any ideas how to connect these codes? Sorry I am not really a VBA expert. I made a google sheet to show what I actually mean, but I need this in excel VBA, the google sheet is just to visualize what I mean: https://docs.google.com/spreadsheets/d/1OU_95Lhf6p0ju2TLlz8xmTegHpzTYu4DW0_X57mObBc/edit#gid=0

THis is my code right now:

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

回答1:

Here the code you need

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

Update as your google sheet

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

Next Update

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

回答2:

You must have general module (not object module), if no, insert new module, and put this:

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

Call the function in cell G3 by formula:

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

Copy Cell G3 to G4:G1000 (or as your last possible row)

Last, in ThisWorkBook Module as we use before, clear all code, and add this code:

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

And do test

来源：https://stackoverflow.com/questions/59900660/creating-a-data-history-with-excel-vba-using-lastrow-time-stamp-and-workbook-sh

标签

excel

vba

timestamp