Sub Sbor_imen_failov_i_stranic()
    Dim i As Long
    Dim xRg As Range
    Dim xStr As String
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Dim xFileNum As Long
    Dim RegExp As Object
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
        Worksheets.Add.Name = "Приложения"
        Set xRg = Sheets("Приложения").Range("A1")
        Range("A:B").ClearContents
        Range("A1:B1").Font.Bold = True
        xRg = "Имя файла"
        xRg.Offset(0, 1) = "Кол-во страниц"
        i = 2
        xStr = ""
        Do While xFileName <> ""
            Cells(i, 1) = xFileName
            Set RegExp = CreateObject("VBscript.RegExp")
            RegExp.Global = True
            RegExp.Pattern = "/Type\s*/Page[^s]"
            xFileNum = FreeFile
            Open (xFdItem & xFileName) For Binary As #xFileNum
                xStr = Space(LOF(xFileNum))
                Get #xFileNum, , xStr
            Close #xFileNum
            Cells(i, 2) = RegExp.Execute(xStr).Count
            i = i + 1
            xFileName = Dir
        Loop
        Columns("A:B").AutoFit
    End If
End Sub

Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator

Sub Подготовка_удалить_колонки()

'Первая часть макроса: Перемещаем листы в новую книгу
Dim ActiveSht As Worksheet
Dim NewWb As Workbook
For Each ActiveSht In ThisWorkbook.Worksheets
ActiveSht.Visible = True ' делаем скрытые листы видимыми в исходной книге.
Next
 
Sheets(Array("Исходные данные", "Сопровод", "ПЗ МЭР", "ПЗ", "КЦ", "Справочник")).Move ' Здесь указываете имена нужных листов
Set NewWb = ActiveWorkbook
For Each ActiveSht In NewWb.Worksheets
With ActiveSht.UsedRange
.Value = .Value
End With
Next
'NewWb.SaveAs FileName:="C:\" & "Копия.xls" ' листов стало много - какое имя нужно давать для книги не знаю.
MsgBox "Формы документов перенесены в новую книгу и сохранены.", , ""
'ThisWorkbook.Close SaveChanges:=False


'Вторая часть макроса: удаление внешних связей
exist_links = ActiveWorkbook.LinkSources(xlExcelLinks)

If Not IsEmpty(exist_links) Then
For i = LBound(exist_links) To UBound(exist_links)
' MsgBox exist_links(i)
ActiveWorkbook.BreakLink name:=exist_links(i), Type:=xlLinkTypeExcelLinks
Next
Else
MsgBox "Связей не найдено"
End If

'Третья часть макроса: Настройка формата под себя
    Set wb = ActiveWorkbook
    'Sheets("Исходные данные").UsedRange.Value = Sheets("Исходные данные").UsedRange.Value
    'Sheets("ПЗ МЭР").UsedRange.Value = Sheets("ПЗ МЭР").UsedRange.Value
    'Sheets("ПЗ").UsedRange.Value = Sheets("ПЗ").UsedRange.Value
    Application.DisplayAlerts = False
    Sheets("Справочник").Delete
    Application.DisplayAlerts = True
    'Sheets("КЦ").Visible = xlSheetsHidden
    Sheets("Ф.1(1д)").Visible = xlSheetsHidden
...

Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value

Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value

Sub Тест_выделения_диапозона()
Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value
Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value
End Sub

Sub Auto_Open()
Workbooks.Open Filename:="...\СцепитьЕсли2.xlam"
End Sub