Sub Удалить_Строки()
    Sheets(Array("Яблоко", "Груша")).Select
    ActiveCell.Rows("1:4").EntireRow.Select
    Selection.Delete Shift:=xlUp
    ActiveCell.Select
    Sheets("Яблоко").Select
End Sub

Sub Collect()
    Dim i As Long, j As Long, a(), b()
    Application.ScreenUpdating = False
    a = Sheets("Лист1").UsedRange.Value: Cells.Clear
    For i = 1 To UBound(a, 2) ' с какого столбика копировать "i = 4"
        j = Cells(Rows.Count, 1).End(xlUp).Row + 1
        b = Application.Index(a, 0, i)
        Cells(j, 1).Resize(UBound(b)).Value = b
    Next
    Columns(1).SpecialCells(4).Delete xlUp
End Sub

Sub Emul_F2()    
ActiveCell.Select
    Dim lCnt As Long
    Do While lCnt < 150
        Application.SendKeys "{F2}"
        Application.SendKeys "{ENTER}"
        lCnt = lCnt + 1
    Loop
End Sub

Sub vst()
Dim wb As String: wb = ThisWorkbook.Path & "\Книга2.xlsm" 'путь к основной книге (куда копировать)
With Application
   .EnableEvents = False
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
   .Visible = False
Workbooks.Open Filename:=wb
ThisWorkbook.Worksheets("Таблица").Cells.Copy ActiveWorkbook.Worksheets("Таблица").Cells 'копируем все данные с активного листа
'Workbooks("Куда.xlsm").Worksheets("Лист1").Range("A1:G25").Copy
ActiveWorkbook.Close (True)
   .EnableEvents = True
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
   .Visible = True
   End With
End Sub

Sub Протянуть_формулу()
    [I12].Resize(Cells(Rows.Count, "a").End(xlUp).Row - 1, 1).FormulaR1C1 = "=VLOOKUP(RC[-7],Повторы!C[-8]:C[-7],2,0)"
End Sub

Sub ReplaceInWord()
    'имя шаблона Word с основным текстом и метками
    Const sWDTmpl As String = "Шаблон.docx"
     
    Dim objWrdApp As Object, objWrdDoc As Object, wdRange As Object
    Dim IsNeedClose As Boolean
    Dim ws As Worksheet
    Dim lr As Long, llastr As Long, lc As Long, llastc As Long
    Dim sPath As String, sToSavePath As String, sWDTmplFullName As String, sWDDocName As String
    Dim sFindVal As String, sReplaceVal As String
    On Error Resume Next
    'пытаемся подключится к объекту Word
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        'если приложение закрыто - создаем новый экземпляр
        Set objWrdApp = CreateObject("Word.Application")
        'делаем приложение видимым. По умолчанию открывается в скрытом режиме
        objWrdApp.Visible = True
        IsNeedClose = True
    End If
    'путь к папке с файлом кода
    'здесь же должен лежать файл шаблона Word
    sPath = ThisWorkbook.Path
    'добавляем разделитель папок, если его нет
    sPath = IIf(Right(sPath, 1) = Application.PathSeparator, "", sPath & Application.PathSeparator)
    'полный путь к файлу шаблона
    sWDTmplFullName = sPath & sWDTmpl
    'создаем папку для сохранения создаваемых файлов Word
    sToSavePath = sPath & Format(Now, "YYYY_MM_DD hh_mm")
    If Dir(sToSavePath, 16) = "" Then
        MkDir sToSavePath
    End If
    sToSavePath = IIf(Right(sToSavePath, 1) = Application.PathSeparator, "", sToSavePath & Application.PathSeparator)
     
    Set ws = Sheets("Word(копировать)")
    With ws
        'определяем последнюю заполненную ячейку на основании столбца А
        llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
        'определяем последний столбец на основании столбца с метками
        llastc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'просмотр начинаем с 3-ей строки, т.к. именно с неё начинаются наши данные
        For lr = 3 To llastr
            'считываем фамилию с инициалами
            sWDDocName = .Cells(lr, 1).Value
            If sWDDocName <> "" Then
                'заменяем точки на пусто для удобочиатемости имен файлов
                sWDDocName = Replace(sWDDocName, ".", "")
                'составляем полный путь к создаваемому файлу,
                'при этом берем тоже расширение файла, что и шаблона
                sWDDocName = sToSavePath & sWDDocName & ".doc"
                'создаем новый документ Word на основании шаблона
                Set objWrdDoc = objWrdApp.Documents.Add(sWDTmplFullName)
                For lc = 1 To llastc
                    'запоминаем метку для поиска в файле Word
                    sFindVal = .Cells(1, lc).Value
                    'этим значением будем заменять текст метки
                    sReplaceVal = .Cells(lr, lc).Text
                    Set wdRange = objWrdDoc.Range
                    'заменяем метки {*} на текст из ячеек
                    wdRange.Find.ClearFormatting
                    wdRange.Find.Replacement.ClearFormatting
                    With wdRange.Find
                        .Text = sFindVal
                        .Replacement.Text = sReplaceVal
                        .Forward = True
                        .Wrap = 1 'wdFindContinue
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                    End With
                    wdRange.Find.Execute Replace:=2 'wdReplaceAll
                Next lc
                'сохраняем созданный документ, но не добавляем в список последних открытых
                objWrdDoc.SaveAs FileName:=sWDDocName, AddToRecentFiles:=False
                'закрываем документ Word
                objWrdDoc.Close False
            End If
        Next
    End With
    If IsNeedClose Then
        'закрываем приложение Word если открывали его кодом
        objWrdApp.Quit
    End If
    'очищаем переменные Word
    Set objWrdDoc = Nothing
    Set objWrdApp = Nothing
    '
    MsgBox "Файлы созданы и сохранены в папке '" & sToSavePath & "'", vbInformation, "www.excel-vba.ru"
End Sub

Sub AAPDF()
    Sheets("Тит.лист").Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ThisWorkbook.Path & "\" & ActiveSheet.name, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Sheets("Протокол").Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ThisWorkbook.Path & "\" & ActiveSheet.name, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Sheets("Отчет").Select
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ThisWorkbook.Path & "\" & ActiveSheet.name, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

Sub Макрос_1()
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & CStr(Worksheets("Лист1").Range("D8")) & ".xlsm"
    Application.DisplayAlerts = True
End Sub

Sub Get_Value_From_Close_Book()
    Dim sShName As String, sAddress As String, vData
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Workbooks.Open "C:\Documents and Settings\Книга1.xls" '"
    sAddress = "A1:C100" 'или одна ячейка - "A1"
    'получаем значение
    vData = Sheets("Лист1").Range(sAddress).Value
    ActiveWorkbook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
    'если надо копировать ячейки с форматами, 
    'то можно использовать стандартные методы копирования вставки
    'objCloseBook.Sheets("Лист1").Range(sAddress).Copy
    '[A1].PasteSpecial xlPasteValues  'вставляем значения
    '[A1].PasteSpecial xlPasteFormats 'вставляем форматы
    'Включаем обновление экрана
    Application.ScreenUpdating = True
End Sub

Sub Копировать_ИЗ()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("D:\Сюда.xlsm")
    vData = objCloseBook.Sheets("Поиск").Range("A3","C5","H4", "G8").Value
    objCloseBook.Close False
    If IsArray(vData) Then
        Sheets("Лист1").Range("A3","C5","H4", "G8").Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        Sheets("Поиск").Range("A3","C5","H4", G8") = vData
    End If
    Application.ScreenUpdating = True
End Sub

.Range("A3","C5")

.Range("A3","C5","H4", "G8")