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

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

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

Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
  With Sheets("Нор_Док_МРК")
    .Range("EC6").Formula2R1C1 = "Да"
  End With
Else
  With Sheets("Нор_Док_МРК")
    .Range("EC6").Formula2R1C1 = "Нет"
  End With
End If
End Sub

Sub Найти_Последнюю_Ячейку()
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 44).End(xlUp).Row
Cells(iLastRow + 1, 1).Select
End Sub

Sub Макрос1()
    With Sheets("Лист2")
       Range("CX4").FormulaR1C1 = "=TEXT(TODAY(),""ДД.ММ.ГГГГ"")&"" в ""&HOUR(NOW())&"":""&MINUTE(NOW())"
    End With
End Sub

Sub Выделить()
Range(Cells(3, 5), Cells(Cells(3, 5).End(xlDown).Row, 5)).Select
End Sub

Sub Протянуть_Формулу()
  With Sheets("Лист1")
    .[H3].Resize(.Cells(.Rows.Count, "F").End(xlUp).Row - 2, 1).FormulaR1C1 = "=IFERROR(VLOOKUP('Лист1'!RC[-2], Лист2!R2C13:R9807C17,2,0),"""")"
  End With
End Sub

Sub CopyDat()
    Dim Sh1 As Worksheet: Dim sAddress As String: Dim objCloseBook As Object: Dim flg As Boolean
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Set Sh1 = ActiveSheet: flg = False
    Set objCloseBook = GetObject(ThisWorkbook.path & "\Книга2.xlsm")
    If objCloseBook.Sheets(Sh1.Name).Application.CountA(objCloseBook.Sheets(Sh1.Name).Cells) > 0 Then
        sAddress = "A1:J" & objCloseBook.Sheets(Sh1.Name).Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        If Sh1.Application.CountA(Sh1.Cells) > 0 Then
            Sh1.Range("A1:J" & Sh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row).Clear
        End If
        objCloseBook.Sheets(Sh1.Name).Range(sAddress).Copy Destination:=[A1]: Application.CutCopyMode = False: flg = True
    Else
        MsgBox "В закрытой книге на листе """ & Sh1.Name & """ отсутствуют данные для переноса!", 48, "Info"
    End If
    On Error Resume Next
    For Each lnk In ThisWorkbook.LinkSources(xlExcelLinks)
        ThisWorkbook.BreakLink lnk, xlLinkTypeExcelLinks
    Next lnk
    On Error GoTo 0
    objCloseBook.Close False: Application.ScreenUpdating = True: [A1].Select: Application.DisplayAlerts = True
    If flg = True Then MsgBox "Готово!", 64, "Info"
End Sub

Sub Копировать_СИ_по_журналам()
    Dim wb As Workbook, c As Range, arrWB(), w
    arrWB = Array("Журнал.xlsm")
    With Application
       .EnableEvents = False
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .Visible = False
         
        For Each w In arrWB
           'Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & w)' Этот метод копирует данные в книги ноходящиеся в одной папке с главной
            Set wb = Workbooks.Open("E:\Сервер\Сервер 1\Сервер 2\Сервер 3\Сервер 4\РАБОЧИЕ ПРОТОКОЛЫ ЭТ НТ\Журнал" & "\" & w) ' Этот метод копирует данные в книги ноходящиеся по пути с главной
            ThisWorkbook.Worksheets("Средства_измерений").Cells.Copy wb.Worksheets("Средства измерений").Cells 'копируем все данные с активного листа
            For Each c In wb.Worksheets("Средства_измерений").Cells.SpecialCells(xlCellTypeFormulas, 23)
                c.FormulaLocal = Replace(c.FormulaLocal, "[" & ThisWorkbook.Name & "]", "")
            Next c
            wb.Close (True)
        Next w
         
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .Visible = True
    End With
    MsgBox "Средства измерения скопированы в журнал"
End Sub