Авторские программы, библиотеки, надстройки и шаблоны - VBA - Ответ 8714389

Sub Копировать_формулу_по_книгам()
    If TypeName(Selection) <> "Range" Then MsgBox "Не выделен диапазон. Работа прекращена.": Exit Sub
    Dim i&, j&, k%, DiaAdr$, NazvLista$, Msg$, r As Range, aBook As Workbook, Sh As Worksheet
    With Application
        .CutCopyMode = xlCopy
        .ScreenUpdating = False
    End With
    Set aBook = ActiveWorkbook
    NazvLista = ActiveSheet.Name
    DiaAdr = Selection.Address()
    Set r = ActiveSheet.Range(DiaAdr)
    For k = 1 To Workbooks.Count
        ' Не работать с образцом и с книгой запуска макроса (Personal или надстройкой)
        If Not ((Workbooks(k) Is aBook) Or (Workbooks(k) Is ThisWorkbook)) Then
            If SheetExists(NazvLista, Workbooks(k)) Then
                With Workbooks(k).Worksheets(NazvLista)
                    .Activate
                    r.Copy
                    With .Range(DiaAdr)
                        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
                        .Select
                        For i = 1 To .Rows.Count
                            For j = 1 To .Columns.Count
                                .Cells(i, j).Formula = r.Cells(i, j).Formula
                            Next
                        Next
                    End With
                End With
            Else
                Msg = Msg & "В книге " & Workbooks(k).Name & " не существует лист " & NazvLista & vbCrLf
            End If
        End If
    Next k
    aBook.Activate
    If Msg <> "" Then MsgBox Msg
    Set aBook = Nothing: Set r = Nothing
End Sub
 
Sub Модификацировать_формулы_по_книгам()
    If TypeName(Selection) <> "Range" Then MsgBox "Не выделен диапазон. Работа прекращена.": Exit Sub
    Dim i&, j&, k%, DiaAdr$, NazvLista$, Msg$, fPrefix$, fPostfix$, F$, r As Range, aBook As Workbook, Sh As Worksheet
    fPostfix = InputBox("Введите добавляемую правую часть формулы либо шаблон изменения, в котором @@@ -старая формула без знака =")
    If fPostfix = "" Then Exit Sub
    If UBound(Split(fPostfix, "@@@")) = 1 Then
        fPrefix = Split(fPostfix, "@@@")(0)
        fPostfix = Split(fPostfix, "@@@")(1)
    End If
    If Left(fPrefix, 1) <> "=" Then fPrefix = "=" & fPrefix
    With Application
        .CutCopyMode = xlCopy
        .ScreenUpdating = False
    End With
    Set aBook = ActiveWorkbook
    NazvLista = ActiveSheet.Name
    DiaAdr = Selection.Address()
    Set r = ActiveSheet.Range(DiaAdr)
    For k = 1 To Workbooks.Count
        ' Не работать с книгой запуска макроса (Personal или надстройкой)
        If Not (Workbooks(k) Is ThisWorkbook) Then
        If SheetExists(NazvLista, Workbooks(k)) Then
            With Workbooks(k).Worksheets(NazvLista)
                .Activate
                r.Copy
                With .Range(DiaAdr)
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
                    .Select
                    For i = 1 To .Rows.Count
                        For j = 1 To .Columns.Count
                            F = .Cells(i, j).Formula
                            If Left(F, 1) = "=" Then F = Mid(F, 2)
                            F = fPrefix & F & fPostfix
                            .Cells(i, j).Formula = F
                        Next
                    Next
                End With
            End With
        Else
            Msg = Msg & "В книге " & Workbooks(k).Name & " не существует лист " & NazvLista & vbCrLf
        End If
        End If
    Next k
    aBook.Activate
    If Msg <> "" Then MsgBox Msg
    Set aBook = Nothing: Set r = Nothing
End Sub
Function SheetExists(SheetName, wb As Workbook) As Boolean
    Dim Sh As Worksheet
    For Each Sh In wb.Worksheets
        If Sh.Name = SheetName Then SheetExists = True: Exit Function
    Next Sh
End Function