Track Changes not working properly

[oloeriu]

Hello guys,

I am trying to build a code that will register every change in a file.

I have built something, but it does not work properly.

I mean that it is not able to register the row/column deletion (it register some lines with the info from the first cell from the row/column) and copy/paste (if I copy 2 or more cells and paste them the code will register the same number of lines as the number of cells have been pasted, but only with the info from the first cell from the selection that has been copied).

I need to know if it possible to do something to register the same number of lines as the number of the cells copied, but with the info from every cell, not only from the first one.
And also, for row/column deletion, I need to know if it is possible to register only one line.

The code can be used for every file. So guys, you can take it and use it (but I prefer to complete it with these 2 things)

I let the code here:


Dim oldValue As String
Dim oldAddress As String

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Log" Then
exists = True
End If
Next i

If Not exists Then
Worksheets.Add.Name = "Log"
Worksheets("Log").Move _
Before:=Worksheets(1)
With Worksheets("Log")
.Unprotect
.Range("A1").Value = "Sheet Name"
.Unprotect
.Range("B1").Value = "Cell Changed"
.Unprotect
.Range("C1").Value = "Old Value"
.Unprotect
.Range("D1").Value = "New Value"
.Unprotect
.Range("E1").Value = "User"
.Unprotect
.Range("F1").Value = "Date & Time"
.Unprotect
.Range("F:F").NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
End If

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngCell As Range
Dim sSheetName As String
sSheetName = ActiveSheet.Name
On Error Resume Next
Worksheets("Log").Unprotect
If ActiveSheet.Name <> "Log" Then

For Each rngCell In Target

If Not IsEmpty(rngCell) Then

If rngCell.Formula = "" Then
Application.EnableEvents = False
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = oldAddress
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = oldValue
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = "Deleted"
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Environ("username")
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = Now
Else

Application.EnableEvents = False
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = oldAddress
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = oldValue
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Target.Value
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Environ("username")
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = Date + Time

Application.EnableEvents = True

End If
End If
Next rngCell
Sheets("Log").Columns("A:F").AutoFit
End If
Worksheets("Log").Protect
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
oldValue = Target.Value
oldAddress = Target.Address
End Sub



I hope somebody can help me! :bow:

Thank you in advance!

[oloeriu]

Nobody? Nothing? :crying:

[Logit]

.
Maybe you can use this resource to add to the existing macro below :

https://stackoverflow.com/questions/7479721/determine-whether-user-is-adding-or-deleting-rows

Paste this into the ThisWorkbook Module :



Option Explicit


Dim vOldVal 'Must be at top of module


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)


Dim bBold As Boolean




If Target.Cells.Count > 1 Then Exit Sub
If ActiveSheet.Name = "Pricing" Then Exit Sub


'On Error Resume Next


With Application
.ScreenUpdating = False
.EnableEvents = False


End With


If IsEmpty(vOldVal) Then vOldVal = "Empty Cell"
bBold = Target.HasFormula
With Sheets("Tracker")
'.Unprotect Password:="Secret"
If .Range("A1") = vbNullString Then
.Range("A1:H1") = Array("Cell Changed", "Old Value", _
"New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User")
End If


With .Cells(.Rows.Count, 1).End(xlUp)(2, 1)
.Value = ActiveSheet.Name & " : " & Target.Address
.Offset(0, 1) = vOldVal
With .Offset(0, 2)
If bBold = True Then
.ClearComments
.AddComment.Text Text:= _
"NOTE :" & Chr(10) & "" & Chr(10) & _
"Bold values are the results of formulas"


End If
.Value = Target
.Font.Bold = bBold

End With
.Offset(0, 3) = Time
.Offset(0, 4) = Date
.Offset(0, 5) = Application.UserName
End With
.Cells.Columns.AutoFit
'.Protect Password:="Secret"
End With


vOldVal = vbNullString


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
On Error GoTo 0


MsgBox "There was a change to this sheet !"
End Sub




Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
vOldVal = Target
End Sub


Private Sub test()
Application.EnableEvents = True
End Sub

[oloeriu]

I have tried it, and it does not work.
In fact the code is working, but it not fit my needs.