Sub МРК_Подразделение_Создать_Протокол()
Dim sh As Worksheet
    For Each sh In Worksheets(Array("Протокол_МРК"))
        With Sheets("Пробник_МРК")
            Select Case sh.Name
            Case "Протокол_МРК"
                .Range("54:57").Copy sh.Range(ActiveCell.Address)
            End Select
        End With
    Next
End Sub

Sub Создать()
With Worksheets("Яблоко")

Application.ScreenUpdating = False
lr = Cells(Rows.Count, 4).End(xlUp).Row
For Each cell In .Range("D100:D" & lr)
If cell = "Подразделение" Then
cell.Select
cell.Offset(0, -3).Select
    МРК_Подразделение_Создать_Протокол 'ваш макрос
End If

If cell = "Показатель" Then
cell.Select
cell.Offset(0, -3).Select
    МРК_Создать_Протокол 'ваш макрос
End If

cell.Offset(0, -2).Select
Next
Application.ScreenUpdating = True

      End With
End Sub

Sub ExistsSheet()
    Dim oConn As Object
    Dim objRS As Object
    Dim sf$, avr, avsh, li&, lr&, lc&
   
    sf = [G1]
    Set oConn = CreateObject("ADODB.Connection")
    oConn.CursorLocation = 3
    oConn.Open "DBQ=" & sf & ";Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=1;"
    Set objRS = oConn.OpenSchema(20) '20 = adSchemaTables, т.е. список таблиц
    'Cells(1, 1).CopyFromRecordset objRS
   
    li = objRS.RecordCount
    avr = objRS.getrows(li, 0)
    ReDim avsh(1 To li, 1 To 1)
    For lr = 0 To li - 1
        avsh(lr + 1, 1) = avr(2, lr)
    Next
    Cells(1, 1).Resize(li, 1).Value = avsh
    objRS.Close
    oConn.Close
    Set objRS = Nothing
    Set oConn = Nothing
End Sub

let
    Источник = Excel.Workbook(File.Contents(Excel.CurrentWorkbook(){[Name="Параметры"]}[Content]{0}[Путь к исходным данным]), null, true),
    Хранилище_заказчик_Sheet = Источник{[Item="Хранилище_заказчик",Kind="Sheet"]}[Data],
    #"Повышенные заголовки" = Table.PromoteHeaders(Хранилище_заказчик_Sheet, [PromoteAllScalars=true]),
    #"Измененный тип" = Table.TransformColumnTypes(#"Повышенные заголовки",{{"weqfd", type text}, {"sdv", type date}, {"dsvd", Int64.Type}, {"sfgv", type text}, {"Column5", type any}, {"Column6", type any}, {"Column7", type any}, {"Column8", type any}, {"Column9", type any}, {"Column10", type any}, {"Column11", type any}, {"Column12", type any}, {"Column13", type any}, {"Column14", type any}, {"Column15", type any}, {"Column16", type any}, {"Column17", Int64.Type}})
in
    #"Измененный тип"

Excel.CurrentWorkbook(){[Name="Параметры"]}[Content]{0}[Путь к исходным данным]

let
    Источник = Excel.Workbook(File.Contents("C:\Users\Valera\Desktop\База данных\Поиск из книги\Пробник.xlsm"), null, true),
    Хранилище_заказчик_Sheet = Источник{[Item="Хранилище_заказчик",Kind="Sheet"]}[Data],
    #"Повышенные заголовки" = Table.PromoteHeaders(Хранилище_заказчик_Sheet, [PromoteAllScalars=true]),
    #"Измененный тип" = Table.TransformColumnTypes(#"Повышенные заголовки",{{"weqfd", type text}, {"sdv", type date}, {"dsvd", Int64.Type}, {"sfgv", type text}, {"Column5", type any}, {"Column6", type any}, {"Column7", type any}, {"Column8", type any}, {"Column9", type any}, {"Column10", type any}, {"Column11", type any}, {"Column12", type any}, {"Column13", type any}, {"Column14", type any}, {"Column15", type any}, {"Column16", type any}, {"Column17", Int64.Type}})
in
    #"Измененный тип"

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

Sub Область_Выделения_2()
Range("A3", Cells(Rows.Count, 11).End(xlUp)).Select
End Sub