Excel VBA: Выборочное копирование новых строк в сводный лист

[Nat16]

Добрый день! Большая просьба помочь с таким вопросом по VBA: есть 2 листа в Excel "Итого", куда ежедневно должны копироваться данные из листа "Вчера". У меня получилось создать очень простой макрос для переноса всех данных из листа "Вчера" на лист "Итого", но нужно дополнить его так, что бы если на листе "Итого" уже есть какие-то строки, которых нет на листе "Вчера" они бы не изменялись и не затирались, а строки, которых раньше не было переносились в общий лист.
Заранее спасибо за понимание - в VBA ориентируюсь плохо.

[Администратор]

По каким столбцам сравнивать строки на этих двух листах, чтобы понять, это одна и та же строка или новая? По всем столбцам или достаточно по одному?

[Nat16]

Достаточно по одному - по первому. В данном случае это ФИО сотрудников организации. Т.е. если сотрудник уже указан в "Итого" а во "Вчера" его нет, то строка сохраняется в прежнем виде.

[Администратор]

Для информации: у двух людей фио могут быть полностью одинаковые.

[Nat16]

Мне бы хотелось понять принцип, не так важно учитывать эти детали. Мы предполагаем, что ФИО не совпадают.

[Администратор]

Здесь две процедуры, поместите их в один модуль. Запускайте только процедуру "Макрос".

Макрос

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

[свернуть]

[Nat16]

Огромное спасибо! Буду разбираться.

[Nat16]

Макрос работает замечательно, спасибо, еще раз. Я только поменяла количество столбцов.
Уточните, пожалуйста, в нем, единственное, не прогружаются данные по тем ФИО, которые уже были на листе "Итого" т.е. данные по другим столбцам ежедневно меняются и их тоже хотелось бы прогружать в "Итого". Мой макрос тут не подойдет т.к. копирует все не разбирая ФИО на строке.
Просьба подсказать, как дополнить Ваш вариант.

[Администратор]

Принцип макроса такой. Макрос удаляет на листе "Итоги" строки с фио, которые есть на листе "Вчера". А затем копирует все данные из листа "Вчера" на лист "Итоги". Таким образом на лист "Итоги" копируются новые фио и изменяются данные у имеющихся фио.

Макрос

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

[свернуть]

[Nat16]

Большое спасибо за оперативный ответ! Все работает отлично, под свою таблицу немного дополнила.

[Администратор]

Если строк на листе-результате надо удалять много, то макрос может медленно работать.
В этом случае можно придумать что-нибудь другое. В программировании одно и то же очень частом можно делать разными способами.