Форум по VBA и MS Office

Sub Макрос()

    Dim shSrc As Worksheet, src(), shRes As Worksheet
    Dim ResFIO As New Collection
    Dim lr As Long, i As Long, r As Long
   
   
    '1. Откл. монитора, чтобы ускорить работу макроса.
    Application.ScreenUpdating = False
   
    '2. Присваивание имён листам, с которыми надо работать.
    Set shSrc = Worksheets("Вчера")
    Set shRes = Worksheets("Итого")
   
    '3. Отображение скрытых строк. Это нужно для метода End, который не ищет в скрытых строках.
    If shSrc.AutoFilterMode = True Then shSrc.AutoFilter.ShowAllData
    If shRes.AutoFilterMode = True Then shRes.AutoFilter.ShowAllData
    shSrc.Rows.Hidden = False
    shRes.Rows.Hidden = False
   
    '4. Копирование столбца с фио из листа-источника в массив. С массивом быстрее работать,
        ' чем с эксель-ячейками.
    ' Поиск последней строки в столбце с фио.
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    ' Если лист пустой.
    If lr = 1 Then
        Application.ScreenUpdating = True
        MsgBox "На листе ""Вчера"" нет данных в столбце ""A"".", vbExclamation
        Exit Sub
    End If
    ' Копирование столбца с фио в массив.
    src() = shSrc.Range("A1:A" & lr).Value
   
    '5. Запись фио из листа-результата в коллекцию.
        ' Коллекция ускорит работу макроса, если данных будет много.
    GetResFIO shRes, ResFIO
   
    '6. Поиск последней строки на листе-результате, чтобы знать, куда вставлять новые данные.
    r = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
   
    '7. Копирование данных из листа-источника на лист-результат.
        ' Если этот способ будет долгим, то данные сначала можно будет записать в vba-массив,
        ' а затем vba-массив вставить на лист-результат.
    ' Включение перехватчика ошибок. Ошибка возникнет, если в коллекции не будет данных.
        ' Другого способа проверить, есть или нет в коллекции элемент, нет.
    On Error Resume Next
    For i = 2 To UBound(src, 1)
   
        '1) Делаем бессмысленное действие, чтобы вызвать ошибку.
        If ResFIO(CStr(src(i, 1))) = "" Then
        End If
       
        '2) Если есть ошибка, значит это новая фио.
        If Err.Number <> 0 Then
           
            ' Переход на следующую строку на листе-результате.
            r = r + 1
           
            ' Копирование строки из листа-источника на лист-результат.
                ' Предполагается, что на листах три столбца.
            shRes.Cells(r, "A").Resize(, 3).Value = shSrc.Cells(i, "A").Resize(, 3).Value
           
            ' Сброс ошибки, чтобы потом снова отлавливать ошибку.
            Err.Number = 0
           
        End If
       
    Next i
    ' Откл. перехватчика ошибок.
    On Error GoTo 0
   
    '8. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '9. Сообщение, чтобы было понятно, завершил работу макрос или нет.
    MsgBox "Готово.", vbInformation

End Sub

Private Sub GetResFIO(shRes As Worksheet, ResFIO As Collection)

    ' Запись в коллекцию фамилий из листа-результата.
   
    Dim arr(), lr As Long, i As Long
   
   
    '1. Копирование столбца с фио в массив.
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    If lr = 1 Then
        Exit Sub
    End If
    arr() = shRes.Range("A1:A" & lr).Value
   
    '2. Копирование фио из массива в коллекцию.
    For i = 2 To UBound(arr, 1)
        ' В "Item" ничего не записывается, т.к. нам это не нужно.
        ' Используется "CStr", т.к. в Key можно записать только текст. Вдруг
            ' в ячейке будет не текст, а что-то другое.
        ResFIO.Add Item:="", Key:=CStr(arr(i, 1))
    Next i
   
End Sub

Sub Макрос()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim SrcFIO As New Collection
    Dim lr1 As Long, lr2 As Long
   
   
    '1. Откл. монитора, чтобы ускорить работу макроса.
    Application.ScreenUpdating = False
   
    '2. Присваивание имён листам, с которыми надо работать.
    Set shSrc = Worksheets("Вчера")
    Set shRes = Worksheets("Итого")
   
    '3. Отображение скрытых строк. Это нужно для метода End, который не ищет в скрытых строках.
    If shSrc.AutoFilterMode = True Then shSrc.AutoFilter.ShowAllData
    If shRes.AutoFilterMode = True Then shRes.AutoFilter.ShowAllData
    shSrc.Rows.Hidden = False
    shRes.Rows.Hidden = False
   
    '4. Проверка, что на листе-источнике есть данные.
    ' Поиск последней строки в столбце с фио.
    lr1 = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    ' Если лист пустой.
    If lr1 = 1 Then
        Application.ScreenUpdating = True
        MsgBox "На листе ""Вчера"" нет данных в столбце ""A"".", vbExclamation
        Exit Sub
    End If
   
    '5. Запись фио из листа-источника в коллекцию.
        ' Коллекция ускорит работу макроса, если данных будет много.
    GetSrcFIO shSrc, SrcFIO
   
    ' Удаление на листе-результате строк с фио, которые есть на листе-источнике.
    DelRowsInRes shRes, SrcFIO
   
    '6. Копирование всех данных из листа-источника на лист-результат.
    ' Поиск последних строк.
    lr1 = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    lr2 = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row + 1
    ' Копирование.
    shSrc.Range("A2:C" & lr1).Copy shRes.Cells(lr2, "A")
   
    '7. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '8. Сообщение, чтобы было понятно, завершил работу макрос или нет.
    MsgBox "Готово.", vbInformation

End Sub

Private Sub GetSrcFIO(shSrc As Worksheet, SrcFIO As Collection)

    ' Запись в коллекцию фамилий из листа-источника.
   
    Dim arr(), lr As Long, i As Long
   
   
    '1. Копирование столбца с фио в массив.
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    arr() = shSrc.Range("A1:A" & lr).Value
   
    '2. Копирование фио из массива в коллекцию.
    For i = 2 To UBound(arr, 1)
        ' В "Item" ничего не записывается, т.к. нам это не нужно.
        ' Используется "CStr", т.к. в Key можно записать только текст. Вдруг
            ' в ячейке будет не текст, а что-то другое.
        SrcFIO.Add Item:="", Key:=CStr(arr(i, 1))
    Next i
   
End Sub

Private Sub DelRowsInRes(shRes As Worksheet, SrcFIO As Collection)

    ' Удаление на листе-результате строк с фио, которые есть на листе-источнике.
   
    Dim res(), lr As Long, i As Long
   
   
    '1. Копирование столбца с фио из листа-результата в массив. С массивом быстрее работать,
        ' чем с эксель-ячейками.
    ' Поиск последней строки в столбце с фио.
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    ' Если лист пустой.
    If lr = 1 Then
        Exit Sub
    End If
    ' Копирование.
    res() = shRes.Range("A1:A" & lr).Value
   
    '2. Удаление строк.
    On Error Resume Next
        For i = UBound(res, 1) To 2 Step -1
       
            ' Бессмысленное действие, чтобы проверить, есть ли фио в коллекции.
            If SrcFIO(CStr(res(i, 1))) = "" Then
            End If
           
            ' Если есть фио.
            If Err.Number = 0 Then
                ' Удаление строки.
                shRes.Rows(i).Delete
            ' Если нет фио.
            Else
                ' Сброс "Err", чтобы дальше можно было сделать проверку.
                Err.Number = 0
            End If
        Next i
    On Error GoTo 0
   
End Sub