Sub Значение_фильтр_2()
Dim smallrng As Range
With Sheets("Лист1")
    .Range("B12", .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Value = .Range("B12", .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Value
    For Each smallrng In Selection.Areas
        smallrng.Value = smallrng.Value
    Next smallrng
 End With
End Sub

Sub Значение_фильтр_2()
    Dim smallrng As Range
    Range("B12", Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Select
    For Each smallrng In Selection.Areas
        smallrng.Value = smallrng.Value
    Next smallrng
End Sub

Sub Значение_фильтр_2()
    Dim smallrng As Range

With Sheets("Лист1")
    .Range("B12", Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Select
    For Each smallrng In Selection.Areas
        smallrng.Value = smallrng.Value
    Next smallrng
 End With

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Application.DisplayAlerts = False
    Me.SaveCopyAs "C:\Users\Volna\Desktop\БД\Сохранение\" & Left(Me.Name, InStrRev(Me.Name, ".") - 1) & "_Связь" & Mid(Me.Name, InStrRev(Me.Name, "."))
    Application.DisplayAlerts = True
End Sub

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