Форум по VBA и MS Office

Sub макрос()
   
    Dim sh_act As Worksheet
    Dim FN_folder As String, FileName As String, bk As Workbook
    Dim lr As Long, i As Long
   
   
    ' Отключение монитора, чтобы ускорить макрос и чтобы не видеть открываемые файлы.
    Application.ScreenUpdating = False
   
    '1. Присваиваем активному листу имя "sh_act". Будем обращаться в коде к активному листу
        ' по имени "sh_act". Дальше в коде будут открываться другие файлы и активный файл
        ' будет другой.
    Set sh_act = ActiveSheet
   
    '2. В переменную запишите полное имя (путь + имя) папки, в которую надо сохранить файлы.
    FN_folder = "C:\Users\User\Desktop\Результат"
   
    '3. Поиск последней строки.
        ' End не ищет в скрытых строках.
    lr = sh_act.Cells(sh_act.Rows.Count, "D").End(xlUp).Row
   
    '4. Пересохранение файлов.
    ' Движение по строкам.
    For i = 2 To lr
        ' Открытие файла и присваение ему имени "bk".
            ' Затем в коде можно будет обращаться к файлу по имени "bk".
        Set bk = Workbooks.Open(FileName:=sh_act.Cells(i, "D").Value, ReadOnly:=True)
        ' Запись в переменную имени файла без пути и расширения, чтобы подставить в имя pdf-файла.
        FileName = Mid(sh_act.Cells(i, "D").Value, InStrRev(sh_act.Cells(i, "D").Value, "\") + 1)
        FileName = Left(FileName, InStrRev(FileName, ".") - 1)
        ' Пересохранение файла в pdf-формат.
        bk.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FN_folder & "\" & FileName & ".pdf", OpenAfterPublish:=False
        ' Закрытие файла.
        bk.Close SaveChanges:=False
    Next i
   
    '5. Вкл. монитора и сообщение.
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation

End Sub