Olá tenta o código...
Sub PDFActiveSheet_Automatic()
'Macro SALVAR PDF com captação de nome automatico
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo ErrHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd.mm.yyyy\_hh.mm")
'Pegar diretório atual, se estiver salvo
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'Trocar espeços no nome
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'Criação de nome padrão
strFile = strName & "_" & strTime & ".pdf"
'G5 é o Range que determina o nome automaticamente do arquivo
strPathFile = strPath & Format(Now, "yyyy.mm.dd") & Range("G5") & ".pdf"
'Escolher diretório
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Selecione diretório e nome do arquivo")
'Gerar pdf no diretório escolhido
If myFile <> "Falso" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Mensagem de confirmação
MsgBox "PDF gerado com sucesso: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
ErrHandler:
MsgBox "Não foi possível gerar o PDF", vbCritical
Resume exitHandler
End Sub
Se ajudou, marque como resposta! Obrigado.
