Sub Копирование_данных()
    Dim wb As Workbook
    Dim aw As Workbook
    
    Set aw = Workbooks.Open(ActiveWorkbook.FullName)
    
    'On Error GoTo Inform
    ' открываем книгу откуда будем копировать данные
    Set wb = Workbooks.Open(Application.GetOpenFilename(fileFilter:="Книги Excel (*.xls*), *.xls*", Title:="Введите путь к файлу данных"))
    Set SourceSht = wb.Worksheets(1)
    
    ' определяем последнюю заполненную ячеку
    LastRow = SourceSht.Cells(Rows.Count, "A").End(xlUp).Row

    SourceSht.Range("A2:A" & LastRow).Copy
    
    LastRow_S_B = aw.ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
    LastRow_S_A = aw.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    
    aw.Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    
    SourceSht.Range("B2:B" & LastRow).Copy
    
    aw.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    
    
Exit Sub
    
Inform:
    'Вывести информационное окно с сообщением об ошибке
    MsgBox "Окно закрыто или нажата кнопка " _
    & Chr(34) & "Отмена" & Chr(34) & "!"
    If fileopenname <> False Then wb.Close (False)
End Sub

=ВПР(СЦЕПИТЬ("*";$A9;"*");'Исх. список 1'!$A$9:$AQ$50;СТОЛБЕЦ(Результат_1!B$8);0)

Private Sub Worksheet_Change(ByVal Target As Range)
        For Each cell in Target
         If Not Intersect(cell, Range("A2:A100")) Is Nothing And _
                                       Target.Offset(0,1)="" Then
                With Target.Offset(0, 1)
                    .Value = Now
                    .EntireColumn.AutoFit
                End With
       End If
    Next cell
End Sub

Sub удаление_листов()
    On Error Resume Next
    Dim folder$, coll As Collection
    Dim StartFolder As String
   StartFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop")
  Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
  With oFD
        .Title = "Выбрать папку"
        .ButtonName = "Выбрать папку"
        .Filters.Clear
        .InitialFileName = StartFolder
        .InitialView = msoFileDialogViewLargeIcons
        If oFD.Show = 0 Then Exit Sub
        folder$ = .SelectedItems(1) 'считываем путь к папке
    End With
   
    If Dir(folder$, vbDirectory) = "" Then
        MsgBox "Не найдена папка «" & folder$ & "»", vbCritical, "Нет папки"
        Exit Sub
    End If

    Set coll = FilenamesCollection(folder$, "*.xlsx") ' расширение файлов
    
    If coll.Count = 0 Then
        MsgBox "В папке «" & Split(folder$, "\")(UBound(Split(folder$, "\")) - 1) & "» нет ни одного подходящего файла!", _
               vbCritical, "Что-то пошло не так!!!"
        Exit Sub
    End If
    
    Dim lLastRow As Long
    Dim LName As String
    Dim i As Integer
    Dim y As String
     Dim s As String
    i = 2
    LName = InputBox("Введите название листа: ")
    If LName Like "" Then
        MsgBox "Название листа Карл!!!", vbCritical, "Что-то пошло не так!!!"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set PrWb = ActiveWorkbook
    PrWb.Worksheets.Add After:=Sheets(1)
    ActiveSheet.Name = ("Результат по " + LName)
    PrWb.Worksheets(2).Select
    PrWb.Worksheets(2).Cells(1, 1) = "Обработанные файлы:"
    For Each File In coll
        Set wb = Workbooks.Open(File)
        y = wb.Worksheets(1).Range("B:B").Find(LName).Address
        If y Like "" Then
            wb.Close False
        Else
            s = wb.Worksheets(1).Range(y).Hyperlinks(1).SubAddress
            s = Replace(s, "'", "")
            s = Replace(s, "#", "")
            s = Left(s, (InStr(1, s, "!", vbTextCompare) - 1))
            wb.Worksheets(1).Range(y).Rows.Delete Shift:=xlUp
            wb.Sheets(s).Delete
            wb.Close True
            PrWb.Worksheets(2).Cells(i, 1) = File
            i = i + 1
        End If
        wb = Empty
        y = Empty
    Next
    Application.DisplayAlerts = True
End Sub

Sub Пароль_на_все_листы()
Dim PS As String
Dim Pss As String

PS = InputBox("Пароль", "Снять защиту листа")
Pss = InputBox("Пароль", "Защита листа")

Application.ScreenUpdating = False
For i = 1 To Sheets.Count - 1
Sheets(i).Unprotect Password:=PS
Sheets(i).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=Pss
Sheets(i).EnableSelection = xlUnlockedCells
Next

End Sub

Sub Копируем_листы_в_другую_книгу()


    Dim bookconst As Workbook
    Dim abook As Workbook
    Set abook = ActiveWorkbook 'присваиваем перменную активной книге
    Set bookconst = Workbooks.Open("C:\Users\User\Desktop\Документы\Поставщик1.xlsx") 'присваиваем перменную книге куда необходимо копировать данные
         'переходим в активную книгу откуда необходимо скопировать данные
    abook.Worksheets("Лист1").Activate
    Range("A:I").Copy 'копируем определенный диапазон листа
    bookconst.Worksheets("Лист1").Activate 'активируем лист куда необходимо вставить данные
    Range("A:I").Select 'встаем на ячейку А1
    'вставляем данные ячеек
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
        'вставляем форматы ячеек
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
        'сохранить текущую книгу
    bookconst.Save
        'Закрыть книгу
    bookconst.Close
    abook.Activate
    
        'Книга 2
    Set bookconst = Workbooks.Open("C:\Users\User\Desktop\Документы\Поставщик2.xlsx") 'присваиваем перменную книге куда необходимо копировать данные
         'переходим в активную книгу откуда необходимо скопировать данные
    abook.Worksheets("Лист2").Activate
    Range("A:I").Copy 'копируем определенный диапазон листа
    bookconst.Worksheets("Лист1").Activate 'активируем лист куда необходимо вставить данные
    Range("A:I").Select 'встаем на ячейку А1
    'вставляем данные ячеек
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
        'вставляем форматы ячеек
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
        'сохранить текущую книгу
    bookconst.Save
        'Закрыть книгу
    bookconst.Close
    abook.Activate
    
        'Книга 3
    Set bookconst = Workbooks.Open("C:\Users\User\Desktop\Документы\Поставщик3.xlsx") 'присваиваем перменную книге куда необходимо копировать данные
         'переходим в активную книгу откуда необходимо скопировать данные
    abook.Worksheets("Лист3").Activate
    Range("A:I").Copy 'копируем определенный диапазон листа
    bookconst.Worksheets("Лист1").Activate 'активируем лист куда необходимо вставить данные
    Range("A:I").Select 'встаем на ячейку А1
    'вставляем данные ячеек
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
        'вставляем форматы ячеек
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
        'сохранить текущую книгу
    bookconst.Save
        'Закрыть книгу
    bookconst.Close
    abook.Activate
    
    End Sub