简体   繁体   中英

Log changes in Excel spreadsheet using VBA

I have the following problem. I need to log changes in a spreadsheet. My range goes from A1:M300000.

So far I have managed to log the address of the changed cell, the user, the old value, and the new value.

Now I would like to insert the following functions and need help. It's the first time I come into contact with VBA:

I also want my log file to show the value of a cell in another column. So I know which object it is. Example change cell B26 and now also A26 should be displayed in the log file.

Furthermore, I also want to log when new cells are inserted or existing records are deleted.

Here is my VBA code:

Option Explicit
Dim mvntWert As Variant
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim lngLast As Long
 
Set wks = Worksheets("Protokoll")
lngLast = wks.Range("A65536").End(xlUp).Row + 1
 
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
 
With wks
    .Range("A" & lngLast).Value = Target.Address(0, 0)
    .Range("B" & lngLast).Value = mvntWert
    .Range("C" & lngLast).Value = Target.Value
    .Range("D" & lngLast).Value = VBA.Environ("Username")
    .Range("E" & lngLast).Value = Now
    
End With
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
mvntWert = Target.Value
End Sub

I hope someone can help me. Thank you very much in advance.

greeting

ironman

Please, try the next code, I prepared yesterday for somebody else asking for a similar issue. It needs only one event and should do what you require here:


Private Sub Worksheet_Change(ByVal Target As Range)
 Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
 Dim sh As Worksheet: Set sh = Worksheets("Protokoll")
 Dim UN As String: UN = Application.userName
 
  'sh.Unprotect "" 'it should be good to protect the sheet
 If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
                                     Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")

 Application.ScreenUpdating = False                                     'to optimize the code (make it faster)
 Application.Calculation = xlCalculationManual
 
 If Target.cells.count > 1 Then
    TgValue = extractData(Target)
 Else
    TgValue = Array(Array(Target.value, Target.Address(0, 0)))  'put the target range in an array (or as a string for a single cell)
    boolOne = True
 End If
 Application.EnableEvents = False                                'avoiding to trigger the change event after UnDo
     Application.Undo
     RangeValues = extractData(Target)                           'define the RangeValue
     putDataBack TgValue, ActiveSheet                            'put back the changed data
     If boolOne Then Target.Offset(1).Select
 Application.EnableEvents = True

 Dim columnHeader As String, rowHeader As String
 For r = 0 To UBound(RangeValues)
    If RangeValues(r)(0) <> TgValue(r)(0) Then
        sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
                Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
    End If
 Next r
 
 'sh.Protect ""
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Sub putDataBack(arr, sh As Worksheet)
    Dim i As Long, arrInt, El
    For Each El In arr
        sh.Range(El(1)).value = El(0)
    Next
End Sub
Function extractData(rng As Range) As Variant
    Dim a As Range, arr, count As Long, i As Long
    ReDim arr(rng.cells.count - 1)
    For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
            For i = 1 To a.cells.count
                arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
            Next
    Next
    extractData = arr
End Function

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM