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

Private Sub CommandButton1_Click()
[L6] = IIf([l4] = "", "", IIf([l5] = "", "", IIf([o15] = 0, "", [o15] / [n29] * [l4])))
End Sub

.Range("a4:a" & lrow).ClearContents

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 Переименование_листов()
On Error Resume Next
 
Dim Rng As Range
  Set Rng = Application.InputBox(Prompt:="Выберите ячейку", _
                                   Title:="Заголовок", _
                                   Type:=8)
For i = 1 To Worksheets.Count
Worksheets(i).Activate
Worksheets(i).Name = Range(Rng.Address)
Next i
   
End Sub