Salvar automaticamente em PDF

[Priscylla Vital Vasconcelo]

Bom dia, pessoal! 

Sou iniciante e estou trabalhando em uma planilha onde preciso criar um botão para salvar uma área selecionada em PDF. Uma com nome e destino determinados em uma célula e outro com a criação automática de uma pasta dentro de 😄 salvando os arquivos lá dentro com o nome que estiver em determinada célula. 

Ex.:

A pessoa terá um campo para preencher com o endereço da pasta que ela deseja salvar o exames automaticamente ("Configurações do exame!B26"). Esta célula, na verdade vem assim: ='Configurações do exame'!B26, porém acho que precia tirar o ' pra não dar erro? De qualquer forma tentei com e sem e não deu jeito.

E o nome do arquivo deverá ser o nome do paciente que consta na célula ("Audiograma!X1")

Esta é a área que eu preciso imprimir : ("A1:U55").

Encontrei este código que cria automaticamente uma pasta e funcionou perfeitamente e gostei muito da proposta,   mas o PDF não abriu, com um erro que de que o documento não é um documento em PDF válido. 

Sub CriarPastas()
Dim DATA, Dia, Mes, Ano As String

DATA = Date
Dia = Left(DATA, 2)
Mes = Right(Left(DATA, 5), 2)
Ano = Right(DATA, 4)

'Criar objeto
Set fso = CreateObject("Scripting.FileSystemObject")

'Se não existir a pasta "NomedaPasta", ela é criada.
If Not fso.FolderExists("C:\EasyAudio\") Then
MkDir "C:\EasyAudio\"
End If

'Se não existir a pasta do ano atual dentro da "NomedaPasta", ela é criada.
If Not fso.FolderExists("C:\EasyAudio\" & Ano) Then
MkDir "C:\EasyAudio\" & Ano
End If

'Se não existir a pasta do mês atual dentro da pasta do ano atual, ela é criada.
If Not fso.FolderExists("C:\EasyAudio\" & Ano & "\" & Mes) Then
MkDir "C:\EasyAudio\" & Ano & "\" & Mes
End If

'Se não existir a pasta do dia atual dentro da pasta do mês atual, ela é criada.
If Not fso.FolderExists("C:\EasyAudio\" & Ano & "\" & Mes & "\" & Dia) Then
MkDir "C:\EasyAudio\" & Ano & "\" & Mes & "\" & Dia
End If

'Cria o caminha que será salvo o arquivo.
NameFolder = "C:\EasyAudio\" & Ano & "\" & Mes & "\" & Dia
'Cria o nome do Arquivo, extensão ".xls", troque extensão caso necessário.
NameFile = Range("Audiograma!x1") & " " & Format(Now, "dd_mm_yyyy-hh.mm") & ".pdf"
'Salva o Arquivo.
ThisWorkbook.SaveAs (NameFolder & "\" & NameFile)
End Sub

Este outro também funcionou, porém aqui preciso colocar o destino específico. Não consegui fazer com ele buscasse o destino na célula.

Sub SalvarPDF()

ChDir "C:\Users\prisc\Desktop\Audiometrias"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Range("Audiograma!X1"), Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End Sub

Podem me ajudar? 

Desde já agradeço muito. 

[Priscylla Vital Vasconcelo]

Consegui resolver, pessoal!

Neste código que inicialmente salva o arquivo numa pasta pré-determinada e "fixa" no computador e eu queria fazer referência a um caminho digitado numa célula,

Sub SalvarPDF()

If Range("Configurações!c66").Value <> "" Then

Dim Pasta As String
Dim nome_arquivo As String

'Em ("Configurações!c66") eu coloquei o caminho da pasta. Era uma ordem assim: Escreva aqui o local que você deseja salvar o arquivo,
'assim o código vai puxar automaticamente a pasta que qualquer pessoa escolher. O endereço na célula precisa terminar com \. 

'O nome do arquivo é o texto que consta em Range("nomes!f1" e "Nomes!h4")

Pasta = Range("Configurações!c66").Value

nome_arquivo = Range("nomes!F1") & " " & Format(Now, "dd_mm_yyyy") & "-" & Range("nomes!H4") & ".pdf"
     
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
(Pasta & "\" & nome_arquivo), Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End If

        MsgBox "Salvo com sucesso!" + Chr(13) + Chr(13) & NameFile + Chr(13) + Chr(13) & NameFolder
          

o erro era que minha referência era uma planilha de nome composto "Configurações do exame", quando mudei para apenas "Configurações" funcionou e ficou assim: 

 

No outro código, cujo o intuito era criar uma nova pasta e salvar os arquivos nela com o nome do arquivo referente ao texto contido em determinada célula e estava dando erro na hora de abrir o PDF, a falha era na última linha do código que falava pra salvar ThisWorkBook. Para .PDF isso não funcionou, apenas para .xlsm.

Sendo assim, o código ficou desta forma e funcionando bem!

Sub CriarPasta()
    Dim DATA, Dia, Mes, Ano As String
    
    DATA = Date
    Dia = Left(DATA, 2)
    Mes = Right(Left(DATA, 5), 2)
    Ano = Right(DATA, 4)
    
'Criar objeto
    Set fso = CreateObject("Scripting.FileSystemObject")
    
'Se não existir a pasta "NomedaPasta", ela é criada.
       If Not fso.FolderExists("C:\EasyAudio\") Then
            MkDir "C:\NomedaPasta\"
       End If
       
'Se não existir a pasta do ano atual dentro da "NomedaPasta", ela é criada.
       If Not fso.FolderExists("C:\NomedaPasta\" & Ano) Then
            MkDir "C:\NomedaPasta\" & Ano
       End If
       
'Se não existir a pasta do mês atual dentro da pasta do ano atual, ela é criada.
       If Not fso.FolderExists("C:\NomedaPasta\" & Ano & "\" & Mes) Then
            MkDir "C:\NomedaPasta\" & Ano & "\" & Mes
       End If
       
'Se não existir a pasta do dia atual dentro da pasta do mês atual, ela é criada.
       If Not fso.FolderExists("C:\NomedaPasta\" & Ano & "\" & Mes & "\" & Dia) Then
           MkDir "C:\NomedaPasta\" & Ano & "\" & Mes & "\" & Dia
      End If
      
'Cria o caminha que será salvo o arquivo.
    NameFolder = "C:\NomedaPasta\" & Ano & "\" & Mes & "\" & Dia
'Cria o nome do Arquivo, extensão ".xls", troque extensão caso necessário.
    NameFile = Range("x1") & " " & Format(Now, "dd_mm_yyyy") & ".pdf"
'Salva o Arquivo.
       
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
(NameFolder & "\" & NameFile), Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
       
        MsgBox "Salvo com sucesso!" + Chr(13) + Chr(13) & NameFile + Chr(13) + Chr(13) & NameFolder
        
    End Sub

 

Desculpem a forma que postei inicialmente. É a minha primeira vez em fóruns e eu postei do celular, não tinha visto como fazer esta formatação.

 

Até a próxima!

Editado Setembro 10, 2021 por Priscylla Vital Vasconcelo
Colei o código errado.