oloeriu
09-04-2018, 03:31 AM
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!
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!