Версия для печати

Ведение журнала сделанных в книге изменений

9247 Написать комментарий К комментариям
Что умеет Excel

 

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

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

Итак, Вы решили реализовать данный процесс. Для это Вам необходимо лишь добавить в книгу новый лист с именем «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) = 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) = 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
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) = 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) = 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
    Const sLOGName As String = "\LOG.txt" '"\LOG.xls"
    Application.ScreenUpdating = False
    '==============   только для записи в текстовый файл   ======================
    If Dir(Application.DefaultFilePath & sLOGName, vbDirectory) = "" Then
        Open Application.DefaultFilePath & sLOGName For Output As #1: Close #1
    End If
    '==============   только для записи в отдельный файл Excel ======================
'    If Dir(Application.DefaultFilePath & sLOGName, vbDirectory) = "" Then
'        Set wbLOG = Workbooks.Add
'        wbLOG.SaveAs Application.DefaultFilePath & sLOGName, xlNormal
'    End If
    Set wbLOG = Workbooks.Open(Application.DefaultFilePath & 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) = 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) = 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
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
    Const sLOGName As String = "\LOG.txt" '"\LOG.xls"
    Application.ScreenUpdating = False
    '==============   только для записи в текстовый файл   ======================
    If Dir(Application.DefaultFilePath & sLOGName, vbDirectory) = "" Then
        Open Application.DefaultFilePath & sLOGName For Output As #1: Close #1
    End If
    '==============   только для записи в отдельный файл Excel ======================
'    If Dir(Application.DefaultFilePath & sLOGName, vbDirectory) = "" Then
'        Set wbLOG = Workbooks.Add
'        wbLOG.SaveAs Application.DefaultFilePath & sLOGName, xlNormal
'    End If
    Set wbLOG = Workbooks.Open(Application.DefaultFilePath & 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) = 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) = 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.

Скачать пример »

  Tips_Macro_LOG.xls (50,0 KiB, 1 816 скачиваний)

Так же см.:
→Выделение сделанных изменений
→Запись изменений на листе в примечания

Поддержать автора сайта
Поделиться ссылкой
  1. Сергей
    18 Май 2012 в 14:51 | #1
    Ответить | Цитата

    В очередной раз огромное спасибо! Заработало!)

Страницы комментариев

Комментарий будет добавлен после проверки администратором.
Комментарии, не имеющие отношения к комментируемой статье, будут удаляться без уведомления и объяснения причин. Если есть вопрос по проблеме в Excel- добро пожаловаться на Форум