Option Explicit

Sub Consolidate_Data()
    Dim ws          As Worksheet
    Dim importLastRow As Long, destinationLastRow As Long
    Dim curRow      As Long
    Dim dataToCheck As Variant
    Dim rng As Range, rDel As Range

    ' Указываем целевой лист для консолидации
    Dim destinationSheet As Worksheet
    Set destinationSheet = ThisWorkbook.Worksheets("backup")

    ' Колонка для проверки дубликатов
    Dim importColumnCheck As Long
    importColumnCheck = 2

    Dim destinationColumnCheck As Long
    destinationColumnCheck = 2

    ' Начальная строка данных
    Dim importStartRow As Long
    importStartRow = 4

    Dim destinationStartRow As Long
    destinationStartRow = 4

    ' Проход по всем листам, кроме "backup"
    For Each ws In ThisWorkbook.Sheets

        If ws.Name <> "backup" Then

            ' Получаем последнюю строку в листе-источнике
            importLastRow = ws.Cells(Rows.Count, importColumnCheck).End(xlUp).Row

            ' Перебираем строки на текущем листе
            For curRow = importStartRow To importLastRow

                ' Данные для проверки
                dataToCheck = ws.Cells(curRow, importColumnCheck).Value

                ' Получаем последнюю строку в листе "backup"
                destinationLastRow = destinationSheet.Cells(Rows.Count, destinationColumnCheck).End(xlUp).Row

                ' Проверяем, существует ли запись уже в "backup"
                With destinationSheet.Range(destinationSheet.Cells(destinationStartRow, destinationColumnCheck), destinationSheet.Cells(destinationLastRow, destinationColumnCheck))

                    Set rng = .Find(What:=dataToCheck, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

                    ' Если запись не найдена, копируем
                    If rng Is Nothing Then
                        ws.Range("A" & curRow).EntireRow.Copy destinationSheet.Range("A" & destinationLastRow + 1)
                    End If

                End With

            Next curRow

        End If

    Next ws

    ' Очистка объектов
    Set rng = Nothing
    Set rDel = Nothing
End Sub

Sub Copy_New_Data_All_Sheets()
'''''''' Консолидация данных со всех листов в backup ''''''''

' Объявление переменных
Dim ws As Worksheet ' Текущий обрабатываемый лист
Dim destinationSheet As Worksheet ' Целевой лист для сохранения данных
Dim importLastRow As Long ' Последняя строка с данными в текущем листе
Dim destinationLastRow As Long ' Последняя строка в целевом листе
Dim dataToCheck As Variant ' Значение ячейки для проверки дубликатов
Dim curRow As Long ' Текущая строка в исходном листе
Dim rng As Range, rDel As Range ' Диапазоны для поиска и удаления
Dim importColumnCheck As Integer ' Проверяемый столбец в исходных листах
Dim destinationColumnCheck As Integer ' Проверяемый столбец в целевом листе
Dim importStartRow As Integer ' Стартовая строка данных в исходных листах
Dim destinationStartRow As Integer ' Стартовая строка в целевом листе

' Настройки (можно менять под свои нужды)
importColumnCheck = 2 ' Проверяем столбец B (2) в исходных листах
destinationColumnCheck = 2 ' Проверяем столбец B (2) в целевом листе
importStartRow = 4 ' Данные начинаются с 4 строки в исходных листах
destinationStartRow = 4 ' Данные начинаются с 4 строки в целевом листе

' Инициализация целевого листа
Set destinationSheet = ThisWorkbook.Sheets("backup")

' Цикл по всем листам книги
For Each ws In ThisWorkbook.Worksheets

' Пропускаем целевой лист "backup"
If ws.Name <> "backup" Then

' Находим последнюю строку с данными в текущем листе
importLastRow = ws.Cells(ws.Rows.Count, importColumnCheck).End(xlUp).Row

' Цикл по строкам данных текущего листа
For curRow = importStartRow To importLastRow

' Получаем значение для проверки
dataToCheck = ws.Cells(curRow, importColumnCheck).Value

' Находим последнюю строку в целевом листе
destinationLastRow = destinationSheet.Cells(destinationSheet.Rows.Count, destinationColumnCheck).End(xlUp).Row

' Поиск дубликатов в целевом листе
With destinationSheet.Range(destinationSheet.Cells(destinationStartRow, destinationColumnCheck), _
  destinationSheet.Cells(destinationLastRow, destinationColumnCheck))
Set rng = .Find(What:=dataToCheck, _
  LookIn:=xlValues, _
  LookAt:=xlWhole, _
  SearchOrder:=xlByRows, _
  SearchDirection:=xlNext, _
  MatchCase:=False)

' Если дубликат не найден
If rng Is Nothing Then
' Копируем всю строку в конец целевого листа
ws.Rows(curRow).Copy Destination:=destinationSheet.Cells(destinationLastRow + 1, 1)

' Помечаем строку для удаления (опционально)
If rDel Is Nothing Then
Set rDel = ws.Range("A" & curRow)
Else
Set rDel = Union(rDel, ws.Range("A" & curRow))
End If
End If
End With
Next curRow
End If
Next ws

' Удаление обработанных строк (раскомментировать при необходимости)
'If Not rDel Is Nothing Then rDel.EntireRow.Delete

' Очистка памяти
Set destinationSheet = Nothing
Set ws = Nothing
MsgBox "Консолидация завершена!", vbInformation
End Sub