Создание истории данных в Excel VBA с использованием LastRow, Time Stamp и Workbook.sheetchange

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. Я сделал Google лист, чтобы показать, что я на самом деле имею в виду, но мне нужно это в Excel VBA, Google лист просто для того, чтобы визуализировать, что я имею в виду: 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

Обновление как ваш лист Google

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 для оценки полностью:

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

И сделать тест