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

If ActiveSheet.Name <> "Лист1" Then
        MsgBox "Чтобы выполнить команду, откройте Лист1", vbInformation, "Внимание!!!"
        Exit Sub
    End If
If Intersect(ActiveCell, Range("A:A")) Is Nothing And Intersect(ActiveCell, Range("A:A")) Is Nothing Then
        MsgBox "Чтобы выполнить команду, выделите нужную ячейку в столбце A", vbInformation, "Внимание!!!"
        Exit Sub
    End If