MyTetra Share
Делитесь знаниями!
Отслеживание изменений и ведение журнала при помощи кода
16.03.2019
23:43
Текстовые метки: log,vba
Раздел: !Закладки - VBA - Разобрать

Отслеживание изменений и ведение журнала при помощи кода
Изменения можно отслеживать и при помощи кода. При этом такой метод дает не менее полное представление об изменениях в ячейках и при этом давать общий доступ книге нет необходимости, а следовательно и все ограничения, применимые для книг в общем доступе тоже остаются за бортом, что делает такой подход порой предпочтительнее. Единственное, при таком режиме файл нельзя будет редактировать одновременно нескольким пользователям. Но в большинстве случаев этого и не надо.
Я могу предложить небольшой код, который будет отслеживать следующие параметры:

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

Итак, Вы решили реализовать данный процесс. Изначально необходимо разрешить макросы, без этого данный способ ведения журнала не сработает. Далее необходимо добавить в книгу новый лист с именем 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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

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

Что такое модуль книги и как туда вставить код подробно описано в этой статье. Если кратко: открываем редактор VBA(Alt+F11) -находим в списке объектов ЭтаКнига(ThisWorkbook) -двойной щелчок по ней и в окно редактора справа вставляется этот код.

Лист "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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

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\Рабочий стол"

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

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

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

Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования