Сайт для приватного користування

Как часто Вы сталкивались с подобной проблемой: есть один файл, которым пользуются несколько человек. Каждый делает какие-то изменения. И вот в какой-то момент надо узнать — а кто сделал то или иное изменение? Возможно просто для информации, а бывает, когда это необходимо и для того, чтобы узнать кто конкретно внес изменение, которое делать было нельзя и по возможности восстановить хоть часть того, что было. Я могу предложить Вам небольшой код, который будет отслеживать следующие параметры:

• Имя пользователя(учетная запись пользователя на компьютере), сделавшего изменения
• адрес ячейки, в которую были внесены изменения
• дата и время внесения изменений
• имя листа, в котором были сделаны изменения
• значение ячейки до изменения(старое значение)
• значение ячейки после изменения(новое значение).

Итак, Вы решили реализовать данный процесс. Для это Вам необходимо лишь добавить в книгу новый лист с именем LOG и вставить приведенный код в модуль книги, изменения в которой Вы хотите отслеживать:

-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Option Explicit
Public sValue As String
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 If Sh.Name = "LOG" Then Exit Sub
 Dim sLastValue As String
 Dim lLastRow As Long

 With Sheets("LOG")
 lLastRow = .Cells.SpecialCells(xlLastCell).Row + 1
 If lLastRow = Rows.Count Then Exit Sub
 Application.ScreenUpdating = False: Application.EnableEvents = False
 .Cells(lLastRow, 1) = CreateObject("wscript.network").UserName
 .Cells(lLastRow, 2) = Target.Address(0, 0)
 .Cells(lLastRow, 3) = Format(Now, "dd.mm.yyyy HH:MM:SS")
 .Cells(lLastRow, 4) = Sh.Name
 .Cells(lLastRow, 5).NumberFormat = "@"
 .Cells(lLastRow, 5) = sValue
 If Target.Count > 1 Then
 Dim rCell As Range, rRng As Range
 On Error Resume Next
 Set rRng = Intersect(Target, Sh.UsedRange): On Error GoTo 0
 If Not rRng Is Nothing Then
 For Each rCell In rRng
 If Not IsError(Target) Then sLastValue = sLastValue & "," & rCell Else sLastValue = sLastValue & "," & "Err"
 Next rCell
 sLastValue = Mid(sLastValue, 2)
 Else
 sLastValue = ""
 End If
 Else
 If Not IsError(Target) Then sLastValue = Target.Value Else sLastValue = "Err"
 End If
 .Cells(lLastRow, 6).NumberFormat = "@"
 .Cells(lLastRow, 6) = sLastValue
 End With
 Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
 If Sh.Name = "LOG" Then Exit Sub
 If Target.Count > 1 Then
 Dim rCell As Range, rRng As Range
 On Error Resume Next
 Set rRng = Intersect(Target, Sh.UsedRange): On Error GoTo 0
 If rRng Is Nothing Then Exit Sub
 For Each rCell In rRng
 If Not IsError(rCell) Then sValue = sValue & "," & rCell Else sValue = sValue & "," & "Err"
 Next rCell
 sValue = Mid(sValue, 2)
 Else
 If Not IsError(Target) Then sValue = Target.Value Else sValue = "Err"
 End If
End Sub

---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Что такое модуль книги и как туда вставить код см. здесь.

Лист «LOG» рекомендую сделать скрытым, иначе смысла в этом всем мало. Как сделать очень скрытый лист см.здесь.

Для того, чтобы хранить историю изменений в отдельном текстовом файле или отдельной книге Excel можно применить такой код:

---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Option Explicit
Public sValue As String
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 If Sh.Name = "LOG" Then Exit Sub
 Dim sLastValue As String
 Dim lLastRow As Long, wbLOG As Workbook
 Dim sPath as String
 Const sLOGName As String = "\LOG.txt" '"\LOG.xls"
 sPath = Application.DefaultFilePath
 Application.ScreenUpdating = False
 '============== только для записи в текстовый файл ======================
 If Dir(sPath & sLOGName, vbDirectory) = "" Then
 Open sPath & sLOGName For Output As #1: Close #1
 End If
 '============== только для записи в отдельный файл Excel ======================
' If Dir(sPath & sLOGName, vbDirectory) = "" Then
' Set wbLOG = Workbooks.Add
' wbLOG.SaveAs sPath & sLOGName, xlNormal
' End If
 Set wbLOG = Workbooks.Open(sPath & sLOGName)
 '============================================================================
 With wbLOG.Sheets(1)
 lLastRow = .Cells.SpecialCells(xlLastCell).Row + 1
 If lLastRow = .Rows.Count Then Exit Sub
 Application.ScreenUpdating = False: Application.EnableEvents = False
 .Cells(lLastRow, 1) = CreateObject("wscript.network").UserName
 .Cells(lLastRow, 2) = Target.Address(0, 0)
 .Cells(lLastRow, 3) = Format(Now, "dd.mm.yyyy HH:MM:SS")
 .Cells(lLastRow, 4) = Sh.Name
 .Cells(lLastRow, 5).NumberFormat = "@"
 .Cells(lLastRow, 5) = sValue
 If Target.Count > 1 Then
 Dim rCell As Range, rRng As Range
 On Error Resume Next
 Set rRng = Intersect(Target, Sh.UsedRange): On Error GoTo 0
 If Not rRng Is Nothing Then
 For Each rCell In rRng
 If Not IsError(Target) Then sLastValue = sLastValue & "," & rCell Else sLastValue = sLastValue & "," & "Err"
 Next rCell
 sLastValue = Mid(sLastValue, 2)
 Else
 sLastValue = ""
 End If
 Else
 If Not IsError(Target) Then sLastValue = Target.Value Else sLastValue = "Err"
 End If
 .Cells(lLastRow, 6).NumberFormat = "@"
 .Cells(lLastRow, 6) = sLastValue
 End With
 wbLOG.Close 1
 Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
 If Sh.Name = "LOG" Then Exit Sub
 If Target.Count > 1 Then
 Dim rCell As Range, rRng As Range
 On Error Resume Next
 Set rRng = Intersect(Target, Sh.UsedRange): On Error GoTo 0
 If rRng Is Nothing Then Exit Sub
 For Each rCell In rRng
 If Not IsError(rCell) Then sValue = sValue & "," & rCell Else sValue = sValue & "," & "Err"
 Next rCell
 sValue = Mid(sValue, 2)
 Else
 If Not IsError(Target) Then sValue = Target.Value Else sValue = "Err"
 End If
End Sub

--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Файл хранится в папке "Мои документы" пользователя. Имя файла — LOG.txt задается посредством константы

Const sLOGName As String = "\LOG.txt"

Чтобы вести изменения в отдельной книге Excel надо будет всего лишь закомментировать строки под «только для записи в текстовый файл» и раскомментировать строки под «только для записи в отдельный файл Excel» и поменять значение для константы

Const sLOGName As String = "\LOG.xls"

Не следует оставлять оба этих блока — они противоречат друг другу и если оставить оба, то будет создан текстовый файл, но изменения все равно будут заноситься в отдельную книгу Excel.
Если хотите, чтобы файл с хранился в папке, отличной от "Мои документы", то необходимо

Application.DefaultFilePath заменить на нужный путь

sPath = "C:\Users\The_Prist\Рабочий стол"

При изменении данного параметра необходимо учитывать, что не у всех пользователей может быть доступ к конкретной папке.