Sub Копировать_В_путь_в_определенной_ячейки()
With Sheets("Лист1")
End With
Dim wb As String: wb = [A1] 'путь к основной книге (куда копировать)
With Application
   .EnableEvents = False
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=wb
ThisWorkbook.ActiveSheet.Range("C10:C11").Copy ActiveWorkbook.Sheets("Лист2").Range("A10") 'копируем все данные с активного листа
ThisWorkbook.ActiveSheet.Range("E10:E11").Copy ActiveWorkbook.Sheets("Лист2").Range("B10") 'копируем все данные с активного листа
ActiveWorkbook.Close (True)
   .EnableEvents = True
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
Application.ScreenUpdating = False
End With
End Sub

Sub Добавить_Строки()
Dim iSh As Worksheet
Application.ScreenUpdating = False
For Each iSh In ThisWorkbook.Worksheets
  With iSh
  If .Name = "Яблоко" Or .Name = "Груша" Then
    .Rows(ActiveCell.Row).Rows("1:4").Insert Shift:=xlDown 'Вариант №1
    '.Rows(ActiveCell.Row).Resize(4).Insert Shift:=xlDown 'Вариант №2
  End If
  End With
Next
Application.ScreenUpdating = True
End Sub

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