Архив

Публикации с меткой ‘Изменения в книге’

Выделение сделанных изменений

1 Май 2011 Нет комментариев

 

Рассмотрим такую ситуацию. Вы работаете в большой компании. Есть файл Excel, в котором работаете не только Вы, но и другие люди. Но Вы хотите узнать какие изменения внесли эти люди в Ваш файл и пометить измененные ячейки цветом(пусть будет красный). Приведенный ниже код поможет это сделать.

Option Explicit
Dim vValue
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target <> vValue Then Target.Interior.Color = vbRed
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then vValue = Target
End Sub
Option Explicit
Dim vValue
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target <> vValue Then Target.Interior.Color = vbRed
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then vValue = Target
End Sub

Вставляем код: Правый щелчок мыши по ярлычку листа(изменения в котором Вы хотите отследить)-Исходный текст-Вставляем приведенный код. Подробнее о вставке кода в модули листа см.здесь.

Но приведенный код работает только в одном листе(том, в модуле которого размещен код). Если Вы хотите отследить изменения во всех листах книги, то воспользуйтесь следующим кодом:

Option Explicit
Dim vValue
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target <> vValue Then Target.Interior.Color = vbRed
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count = 1 Then vValue = Target
End Sub
Option Explicit
Dim vValue
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target <> vValue Then Target.Interior.Color = vbRed
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count = 1 Then vValue = Target
End Sub

Правда вставлять этот код надо уже не в модуль конкретного листа, а в модуль книги. Подробнее о модуле книги см. здесь.

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

  Tips_Macro_Watch_Changes.xls (30,0 KiB, 1 199 скачиваний)

Так же см.:
→Ведение журнала сделанных в книге изменений
Categories: Tags: ,

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

1 Май 2011 41 comments

 

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

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

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

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

Как отследить событие(например выделение ячеек) в любой книге?

1 Май 2011 Нет комментариев

 

Иногда при разработке надстройки просто необходимо отследить какое-либо событие в книге. Но модуль ЭтаКнига и модули листов надстройки позволяют отследить лишь те события, которые происходят в самой надстройке. А как же другие книги? Как, например, отследить событие открытия книги в Excel? Или выделение ячейки в любой книге?

Очень просто:

В модуле ЭтаКнига главной книги(надстройка либо PERSONAL.XLS) создаете переменную

Private WithEvents App As Application
Private WithEvents App As Application

На событие открытия главной книги(той, в которой пишется код и в которой Вы обявили переменную App) присваиваете ей значение:

Private Sub Workbook_Open()
    Set App = Application
End Sub
Private Sub Workbook_Open()
    Set App = Application
End Sub

и создаете событие(аналогично выбору других событий в книге — в левом окне выбора объектов выбираете App. А в правом появятся все доступные события).

Вот так будет выглядеть код отслеживания открытия любой книги:

Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
    MsgBox "Вы открыли книгу:" & Wb.Name
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
    MsgBox "Вы открыли книгу:" & Wb.Name
End Sub

Теперь при открытии любой книги будет появляться сообщение с имененм именно открытой книги.

А с помощью этого кода Вы сможете отследить создание новой книги:

Private Sub App_NewWorkbook(ByVal Wb As Workbook)
    MsgBox "Вы создали новую книгу"
End Sub
Private Sub App_NewWorkbook(ByVal Wb As Workbook)
    MsgBox "Вы создали новую книгу"
End Sub

Отслеживаем выделение ячеек во всех открытых книгах:

Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    MsgBox "Вы выделили ячейку с адресом: " & Target.Address
End Sub
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    MsgBox "Вы выделили ячейку с адресом: " & Target.Address
End Sub

Естественно, вместо показа MsgBox-ов можно назначить выполнение других(нужных) действий. Например, вызов макроса(Call ИмяМакроса). Макрос в таком случае должен быть размещен в стандартном модуле и иметь статус Public(или вовсе без статуса). Сам модуль должен тоже находится в той же книге.

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

  Tips_Macro_How_Catch_Events.xls (29,5 KiB, 1 022 скачиваний)

Также см.:
→Что такое переменная и как правильно её объявить?
Categories: Tags:

Запись изменений на листе в примечания

1 Май 2011 16 comments

 

Сегодня от нечего делать решил написать эту статью. Может кому пригодится. Приведенный ниже код создает примечание в ячейке, если её значение было изменено. В примечание заноситься информация о том, что было занесено в ячейку и когда это было занесено. Если примечание в ячейке уже есть, то в имеющееся примечание допишется информация об изменениях.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oComment As Comment
    On Error Resume Next
    Set oComment = Target.Comment
    If oComment Is Nothing Then
        Target.AddComment Target.Text & " " & Format(Now, "dd.mm.yy HH:MM")
    Else
        oComment.Text oComment.Text & Chr(10) & Target.Text & " " & Format(Now, "dd.mm.yy HH:MM")
    End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oComment As Comment
    On Error Resume Next
    Set oComment = Target.Comment
    If oComment Is Nothing Then
        Target.AddComment Target.Text & " " & Format(Now, "dd.mm.yy HH:MM")
    Else
        oComment.Text oComment.Text & Chr(10) & Target.Text & " " & Format(Now, "dd.mm.yy HH:MM")
    End If
End Sub

Код необходимо поместить в модуль листа(щелкнуть правой кнопкой мыши по ярлычку листа — Исходный текст), изменения на котором необходимо отследить. Подробнее о модулях см.здесь.

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

Option Explicit
Public sValue As String
'заносим в переменную значение ячейки
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then
        sValue = Target.Value
    End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'отслеживаем изменения только в диапазоне "A1:B10"
    If Intersect(Target, Me.Range("A1:B10")) Is Nothing Then Exit Sub
    'сравниваем новое значение с прежним
    If CStr(Target.Value) <> sValue Then
        Dim oComment As Comment
        On Error Resume Next
        Set oComment = Target.Comment
        If oComment Is Nothing Then
            Target.AddComment Application.UserName & ":" & Chr(10) & sValue & " " & Format(Now, "dd.mm.yy HH:MM")
        Else
            oComment.Text oComment.Text & Chr(10) & Application.UserName & ":" & Chr(10) & sValue & " " & Format(Now, "dd.mm.yy HH:MM")
        End If
    End If
End Sub
Option Explicit
Public sValue As String
'заносим в переменную значение ячейки
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then
        sValue = Target.Value
    End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'отслеживаем изменения только в диапазоне "A1:B10"
    If Intersect(Target, Me.Range("A1:B10")) Is Nothing Then Exit Sub
    'сравниваем новое значение с прежним
    If CStr(Target.Value) <> sValue Then
        Dim oComment As Comment
        On Error Resume Next
        Set oComment = Target.Comment
        If oComment Is Nothing Then
            Target.AddComment Application.UserName & ":" & Chr(10) & sValue & " " & Format(Now, "dd.mm.yy HH:MM")
        Else
            oComment.Text oComment.Text & Chr(10) & Application.UserName & ":" & Chr(10) & sValue & " " & Format(Now, "dd.mm.yy HH:MM")
        End If
    End If
End Sub

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

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

  Tips_Macro_ChangesInComment.xls (25,5 KiB, 1 163 скачиваний)

Так же см.:
→Ведение журнала сделанных в книге изменений
→Выделение сделанных изменений
Categories: Tags: