Excel

  Next li

  Application.ScreenUpdating = True

End Sub 

После вставки  просто нажмите Alt+F8 и выполните макрос Zebra. 

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

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

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

адрес ячейки, в  которую были внесены изменения;

дата и время  внесения изменений;

имя листа, в  котором были сделаны изменения;

значение ячейки до изменения(старое значение);

значение ячейки после изменения(новое значение). 

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

                  For Each rCell In Range(Target.Address)

                     If Not IsError(Target) Then sLastValue = sLastValue & "," & rCell Else sLastValue = sLastValue & "," & "Err"

                  Next rCell

                  sLastValue = Mid(sLastValue, 2)

             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

            For Each rCell In Range(Target.Address)

                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" рекомендую сделать скрытым, иначе смысла в  этом всем мало. 
 

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

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

Option Explicit

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 

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

5.5 Как собрать данные с нескольких листов или книг? 

      Очень часто бывает необходимо  собрать данные с нескольких листов, а то и книг. Вручную делать довольно муторно. Чтоб Вам было не так муторно делать эту работу - предлагаю простую процедуру, которая соберет данные из выбранных книг, указанных листов и указанного диапазона на один отдельный лист.

Option Explicit

Sub Consolidated_Range_of_Books_and_Sheets()

    Dim iPivotRange As Range, iDestinationRange As Range, iBeginRange As Range, Sheet

    Dim iRngAddress As String, oAwb As String, DataSheet As String, _

        iCopyAddress As String, sSheetName As String, oFile

    Dim lLastrow As Long, lLastRowMyBook As Long

    Dim iLastColumn As Integer

    Dim Str() As String 

    ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)

    DataSheet = ThisWorkbook.ActiveSheet.Name

    On Error Resume Next

    Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _

                                           "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _

                                           vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)

    If iBeginRange Is Nothing Then Exit Sub

    sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")

    If sSheetName = "" Then sSheetName = "*"

    On Error GoTo 0

    With Application.FileDialog(msoFileDialogFilePicker)

        .AllowMultiSelect = True

        .InitialFileName = "*.*"

        .Title = "Выберите файлы"

        If .Show = False Then Exit Sub

        For Each oFile In .SelectedItems

            Workbooks.OpenText Filename:=oFile

            oAwb = Dir(oFile, vbDirectory) 

            Application.ScreenUpdating = False

            Workbooks(oAwb).Activate

            For Each Sheet In Sheets

                If Sheet.Name Like sSheetName Then

                    Sheet.Activate

                    Select Case iBeginRange.Count

                    Case 1

                        lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row

                        iLastColumn = Cells.SpecialCells(xlLastCell).Column

                        iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address

                    Case Else

                        iCopyAddress = iBeginRange.Address

                        lLastrow = iBeginRange.Rows.Count

                        iLastColumn = iBeginRange.Columns.Count

                    End Select

                    lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cells.SpecialCells(xlLastCell).Row + 1

                    iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address

                    Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(DataSheet).Range(iRngAddress)

                End If

            Next Sheet

            Workbooks(oAwb).Close False

        Next oFile

    End With

    Application.ScreenUpdating = True

End Sub 

Просто вставьте приведенный выше текст в обычный модуль(про модули см.здесь) и потом макрос можно будет вызвать из этой книги, нажатием клавиш Alt+F8 и выбрав его, или создав на листе кнопку и назначив ей макрос. После вызова мароса надо будет указать диапазон сбора данных, имя листа, если необходимо(если не указан - данные будут собраны со всех листов) и выбрать книги для сбора данных. 
 

5.6 Как вставить скопированные ячейки только в видимые/отфильтрованные ячейки 

  В общем-то  смысл статьи уже, думаю, понятен  из названия. Просто чуть-чуть  расширю. 

Ни для кого не секрет, что Excel позволяет выделить только видимые строки(например, если некоторые из них открыты или применен фильтр). 

*если кто-то  не знает, как это сделать:  выделяем диапазон - Alt+;(для английской раскладки);Alt+ж(для русской).  

Так вот, если скопировать  таким образом только видимые  ячейки, то они скопируются как  положено. Но. Если скопировать нефильтрованный  диапазон и попытаться вставить скопированное  в диапазон отфильтрованный(либо содержащий скрытые строки) - то результат вставки будет не совсем такой, как Вы ожидали. Данные будут вставлены даже в скрытые строки. 

Так вот, чтобы  данные вставлялись только в видимые  ячейки, можно применить такой  макрос: 

Option Explicit

Dim rCopyRange As Range

'Этим  макросом копируем  данные

Sub My_Copy()

    If Selection.Count > 1 Then

        Set rCopyRange = Selection.SpecialCells(xlVisible)

    Else: Set rCopyRange = ActiveCell

    End If

End Sub

'Этим  макросом вставляем  данные, начиная с  выделенной ячейки

Sub My_Paste()

    If rCopyRange Is Nothing Then Exit Sub

    If rCopyRange.Areas.Count > 1 Then MsgBox "Вставляемый диапазн не должен содержать более одной области!", vbCritical, "Неверный диапазон": Exit Sub

    Dim rCell As Range, li As Long, le As Long, lCount As Long, iCol As Integer, iCalculation As Integer

    Application.ScreenUpdating = False

    iCalculation = Application.Calculation: Application.Calculation = -4135

    For iCol = 1 To rCopyRange.Columns.Count

        li = 0: lCount = 0: le = iCol - 1

        For Each rCell In rCopyRange.Columns(iCol).Cells

            Do

                If ActiveCell.Offset(li, le).EntireColumn.Hidden = False And _

                   ActiveCell.Offset(li, le).EntireRow.Hidden = False Then

                    rCell.Copy ActiveCell.Offset(li, le): lCount = lCount + 1

                End If

                li = li + 1

            Loop While lCount <= rCell.Row - rCopyRange.Cells(1).Row

        Next rCell

    Next iCol

    Application.ScreenUpdating = False: Application.Calculation = iCalculation

End Sub 

Для полноты  картины, данные макросы лучше назначить  на горячие клавиши(в приведенных  ниже кодах это делается автоматически  при открытии книги с кодом). Для  этого приведенные ниже коды необходимо просто скопировать в модуль ЭтаКнига(ThisWorkbook):