Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Ф4")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("H11:I14")
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Ф4'!$D$425:$AE$457;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Ф4'!$A$425:$A$457;0);ПОИСКПОЗ('Справочник ГТП'!$F$7&H$9;'[" & wbFrom.Name & "]Ф4'!$D$422:$AE$422&'[" & wbFrom.Name & "]Ф4'!$D$423:$AE$423;0));" & """""" & ")"
            ss = Replace(ss, "Ф4", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Ф4","Ф5")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:I14, K11:W14, Y11:Z14,G22:I22, K22:W22, Y22:Z22,G27:I27, K27:W27, Y27:Z27,Y36:Z36,G36:I36, K36:W36, Y36:Z36")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Ф4'!$G$11:$Z$67;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Ф4'!$D$11:$D$67;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Ф4'!$G$9:$Z$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Ф4")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:I14, K11:W14, Y11:Z14,G22:I22, K22:W22, Y22:Z22,G27:I27, K27:W27, Y27:Z27,Y36:Z36,G36:I36, K36:W36, Y36:Z36")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Ф4'!$G$11:$Z$67;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Ф4'!$D$11:$D$67;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Ф4'!$G$9:$Z$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Январь'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("I квартал", "II квартал", "III квартал", "IV квартал", "Год")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G30:J30,G65:J68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]I квартал'!$G$11:$J$68;ПОИСКПОЗ($D30;'[" & wbFrom.Name & "]I квартал'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]I квартал'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "I квартал", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
        FillFormulasInWorkbookk vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Январь'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub
Private Sub FillFormulasInWorkbookk(ByVal sFull As String, wbFrom As Workbook)
    Dim rrr As Range
    Dim shh As Worksheet
    Dim wbb As Workbook
    Set wbb = GetWb(sFull)
      
    If Not wbb Is Nothing Then
        Dim sss As String
        Dim vMonthh As Variant
        For Each vMonthh In Array("I квартал", "II квартал", "III квартал", "IV квартал", "Год")
            Set shh = wb.Sheets(vMonthh)
            Set rrr = sh.Range("G30:J30,G65:J68")
             
            sss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]I квартал'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]I квартал'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]I квартал'!$G$9:$J$9;0));" & """""" & ")"
            sss = Replace(sss, "I квартал", vMonthh)
            rrr.FormulaLocal = sss
        Next
         
        wbb.RemovePersonalInformation = 0
        wbb.Close True
    End If
End Sub
 
Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

   For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь", "I квартал", "II квартал", "III квартал", "IV квартал", "Год")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")

Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Январь'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Dim zapas
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
zapas = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Text
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
было = zapas
Application.EnableEvents = True
стало = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Text
If было <> стало Then
    Set oComment = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Comment
    If oComment Is Nothing Then
        Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").AddComment Date & " было: " & было & " стало: " & стало
    Else
        oComment.Text oComment.Text & Chr(10) & Date & " было: " & было & " стало: " & стало
    End If
    oComment.Shape.TextFrame.AutoSize = True
End If
End Sub

Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($E11;'[" & wbFrom.Name & "]Январь'!$E$11:$E$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub
 
Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function