Макрос для Excel

[Neoneta]

Я прошу прощения, мне в последнем запросе нет нужды сохранять в ПДФ, просто обработать и сохранить в том же формате и с прежним именем

 

[Dragokas]

Тогда

WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    ThisWorkbook.Path & "\" & Cells(iRow, SAVE_NAME_COLUMN) & ".pdf"
WB.Close False

замените на:

WB.Close True

 

[Neoneta]

Не реагирует вовсе макрос, вот мой который я открываю.

Sub aНаВелорапко()
'
' НаВелорапко Макрос
   'снять защиту
    Sheets("дано").Select
    ActiveSheet.Unprotect "qqq"
    Range("B20").Select
    ActiveSheet.Unprotect
    ActiveCell.FormulaR1C1 = ""
    Range("B21").Select
    ActiveCell.FormulaR1C1 = "Батуева М.О."
    Range("B20").Select
    ActiveCell.FormulaR1C1 = "Велорапко О.М."
    'вернуть защиту
    Sheets("дані договору").Select
    ActiveSheet.Protect "qqq"
    'просмотр
    Sheets("04").Activate
    ActiveSheet.Range("F120").Select
    ActiveWorkbook.Save
End Sub

Предупреждение

Пожалуйста, соблюдайте правила форума! Для форматирования кода, обрамляйте его в теги CODE! Подробнее по ссылке.

 

[Dragokas]

Навскидку, макрос как-то грязно записан.
Снимается защита с одного листа ("дано"), а ставится защита уже на совершенно другой лист ("дані договору").
Активируются лишние листы и ячейки, которые не факт, что нужны.
Вообщем, я оставил как есть, если что поправите сами.

Option Explicit

Const PATH_SOURCE_COLUMN As String = "A"
Const SAVE_NAME_COLUMN As String = "C"

Public Sub ExportSheets_AsPDF()
    On Error Resume Next
    Dim oBook As Workbook, WS As Worksheet
    Dim strPath As String
    Dim iRow As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    For iRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        strPath = Cells(iRow, PATH_SOURCE_COLUMN)
        If InStr(strPath, ":\") <> 0 Then 'IsPath
            Set oBook = Workbooks.Open(strPath, True, False)
            If Not (oBook Is Nothing) Then
                ReplaceSurname oBook
                oBook.Close True
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub ReplaceSurname(oBook As Workbook)
    Dim WS As Worksheet
    Set WS = oBook.Sheets("дано")
    'снять защиту
    WS.Unprotect "qqq"
    WS.Unprotect
    WS.Range("B21").FormulaR1C1 = "Батуева М.О."
    WS.Range("B20").FormulaR1C1 = "Велорапко О.М."
    'вернуть защиту
    oBook.Sheets("дані договору").Protect "qqq"
    'просмотр
    oBook.Sheets("04").Activate
End Sub

 

[Neoneta]

Да, то я уже вручную правила (не доправила макрос), вам выслала один пример на основе старой таблици а макрос уже на основе новой. На самом деле там совпадают имена листов. Но не пошел макрос. Ругается.

 

[Dragokas]

Поправил выше.

 

[Neoneta]

Спасибо за помощь, не пойму в чем баг, но макрос не идет-просто после запуска ничего не открывает, изменений не происходит в файлах. Я думаю что остановимся на этом. Мне вы и так очень помогли.

 

[Dragokas]

Если нужно, могу глянуть по удалёнке (в ЛС).