Суть та же... Но папка должна существовать!
Макрос один. Подвязан к обеим кнопкам. По имени текущего листа определяет столбец, где записаны параметры сохранения.
Код |
---|
Sub Печать_PDF()
Dim CurFn As String, CurPath As String, ResFn As String, ResPath As String
Dim cOlFn As Long
Dim tMp As Variant
CurFn = ActiveWorkbook.Name
CurPath = ActiveWorkbook.Path
On Error Resume Next
If ActiveSheet.Name = "Лист2" Then
cOlFn = 1
ElseIf ActiveSheet.Name = "Лист3" Then
cOlFn = 2
Else
Exit Sub
End If
ResPath = ThisWorkbook.Sheets("Лист1").Cells(8, cOlFn).Value
If Len(ResPath) = 0 Then
tMp = MsgBox("не задана папка для отчета!!!", vbOKOnly + vbCritical, "Макрос ""Печать_PDF"":")
Exit Sub
End If
If Len(Dir(ResPath, vbDirectory)) = 0 Then
tMp = MsgBox("не найдена папка """ & ResPath & """ для отчета!!!", vbOKOnly + vbCritical, "Макрос ""Печать_PDF"":")
Exit Sub
End If
ResFn = ThisWorkbook.Sheets("Лист1").Cells(4, cOlFn).Value
On Error GoTo ErrCd
If Len(Dir(ResPath & "\" & ResFn & ".pdf")) Then
Kill ResPath & "\" & ResFn & ".pdf"
End If
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ResPath & "\" & ResFn & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
tMp = MsgBox("Плановое завершение.", vbOKOnly + vbExclamation, "Макрос ""Печать_PDF"":")
Exit Sub
ErrCd:
tMp = MsgBox("аварийное завершение!!!", vbOKOnly + vbCritical, "Макрос ""Печать_PDF"":")
End Sub |
Если файл уже существует, затирает старый и записывает новый.
Если папка должна создаваться самостоятельно, нужно дорабатывать.