salvar arquivo em pdf em pastas diferentes sendo o nome da pasta e do arquivo valores contidos em celulas

[marcelo carlos]

Preciso criar uma rotina VBA para salvar um arquivo(formulário) no formato PDF dentro de pastas nomeadas de 1 a 100 no diretório do meu pc.Sempre que digitar ,por exemplo ,o número 2 na célula D6 e o número 2.1 na célula D4 ,minha rotina deverá salvar esse arquivo com o nome 2.1 dentro da pasta 2.Os valores digitados na célula D6 serão números de 1 a 100 que indicarão em qual das pastas pré definidas do meu diretório o arquivo será salvo com o nome referente ao valor contido na celula d4.Já consegui salvar o documento com o nome desejado porém não dentro das pastas específicas.

 

[marcio.rodrigues]

Olá marcelo carlos

Tente adpatar a sua necessidade:

Sub salvarArquivo()

    Sheets("salvarArquivo").Select
    
    If ActiveSheet.Cells(6, 4).Value = Empty Then Exit Sub
    
    If ActiveSheet.Cells(4, 4).Value = Empty Then Exit Sub
                                
    If Dir(ActiveSheet.Cells(6, 5).Value & ActiveSheet.Cells(6, 4).Value, vbDirectory) <> Empty Then
            
    Else
    
        MsgBox "diretório inexistente ou incorreto"
        
        Exit Sub
        
    End If

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ActiveSheet.Cells(6, 5).Value & ActiveSheet.Cells(6, 4).Value & "\" & ActiveSheet.Cells(4, 4).Value & ".pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    
End Sub

Veja se é por aí...

[marcelo carlos]

Boa noite marcio.rodrigues 

Obrigado por enviar a resposta.Estou usando o código abaixo e também está dando certo quanto a demanda inicial porém agora surgiu uma nova necessidade.Toda vez que digitamos na célula D4 um número de um arquivo já existente e rodamos a macro, o novo arquivo suprime o anterior ,gerando a perda do arquivo.Preciso fazer com que o código não gere um novo arquivo com o mesmo nome do arquivo já existente  e envie uma msg para o usuário via msg Box alertando sobre o erro.Como fazer isso aproveitando o código abaixo?Desde já obrigado.

 

 

Priva te Sub CommandButton1_Click()

 Application.ScreenUpdating = False

 Dim caminho As String

 Dim pasta As Object, NomePasta

 Set pasta = CreateObject("Scripting.FileSystemObject")

 NomePasta = ActiveWorkbook.Path & "\" & Range("d6").Text

 If Not pasta.folderexists(NomePasta) Then

 pasta.createfolder (NomePasta)

 End If

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _

    Filename:=ActiveWorkbook.Path & "\" & Range("d6") & "\" & "Relatório Nº " & Range("d2") & ".pdf", _

    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False

   Application.ScreenUpdating = True

End Sub

[marcio.rodrigues]

Olá marcelo carlos

Na células o ideal e usar a propriedade value (Range("d6").Value)

Teste...

Private Sub CommandButton1_Click()

 Application.ScreenUpdating = False

 Dim caminho As String

 Dim pasta As Object, NomePasta

 Set pasta = CreateObject("Scripting.FileSystemObject")

 NomePasta = ActiveWorkbook.Path & "\" & Range("d6").Value 'alterado

 If Not pasta.folderexists(NomePasta) Then

 pasta.createfolder (NomePasta)

 End If

    If Dir(ActiveWorkbook.Path & "\" & Range("d6").Value & "\" & "Relatório Nº " & Range("d2").Value & ".pdf") = vbNullString Then
            
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=ActiveWorkbook.Path & "\" & Range("d6").Value & "\" & "Relatório Nº " & Range("d2").Value & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False
    
    Else
    
        MsgBox "Arquivo já existente"
        
        Exit Sub
        
    End If

   Application.ScreenUpdating = True

End Sub

Se você quiser que o usuário altere a planilha sem fechar o form, deixe a propriedade ShowModal em FALSE.

Veja se é por ai...

[marcelo carlos]

Boa noite Marcio.Rodrigues 

Código testado.Funcionou corretamente era isso mesmo que o código precisava fazer.Obrigado pela ajuda.

 

 

[marcelo carlos]

Boa Tarde Marcio.Rodrigues e a todos

Uma nova demanda surgiu essa semana e estou tendo dificuldade de fazer o código funcionar.Preciso fazer com que as pastas numeradas criadas a partir do preenchimento das células D2 e D4 do formulário("Teste")  sejam criadas dentro da pasta auditoria, ou seja ,serão subpastas da pasta "Auditoria".

Como ficaria o código para isso ocorrer?

 

[marcio.rodrigues]

Olá marcelo carlos

Altere estas linhas do código e teste:

 NomePasta = ActiveWorkbook.Path & "\Auditoria\" & Range("d6").Value  'alterado

 If Dir(NomePasta & "Relatório Nº " & Range("d2").Value & ".pdf") = vbNullString Then
            
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=NomePasta & "\" & "Relatório Nº " & Range("d2").Value & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False

Veja se é por ai!!!!

[marcelo carlos]

Boa noite Marcio.Rodrigues

Testei o código.Ele está funcionando.Está salvando as pastas numeradas dentro da pasta auditoria. Porém quando digitamos na célula d2 um número de um arquivo  pdf já existente e rodamos o código o mesmo gera um novo arquivo PDF e suprime o anterior sem mostrar a msgbox. Esse esta sendo o incoveniente agora.

 

[marcio.rodrigues]

Olá marcelo carlos

Corrija esta parte de código:

  If Dir(NomePasta & "\" & "Relatório Nº " & Range("d2").Value & ".pdf") = vbNullString Then

 

Veja se é por aí...

[marcelo carlos]

 

Deu certo 

Segue o código.

Obrigado marcio.rodrigues

 

 

Private Sub CommandButton1_Click()

 

Application.ScreenUpdating = False

Dim caminho As String

Dim pasta As Object, NomePasta

Set pasta = CreateObject("Scripting.FileSystemObject")

NomePasta = ActiveWorkbook.Path & "\Auditoria\" & Range("d6").Value

If Not pasta.folderexists(NomePasta) Then

pasta.createfolder (NomePasta)

End If

    If Dir(ActiveWorkbook.Path & "\Auditoria\" & Range("d6").Value & "\" & "Relatório Nº " & Range("d2").Value & ".pdf") = vbNullString Then

           

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _

            Filename:=ActiveWorkbook.Path & "\Auditoria\" & Range("d6").Value & "\" & "Relatório Nº " & Range("d2").Value & ".pdf", _

                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

   

    Else

   

        MsgBox "Arquivo já existente"

       

        Exit Sub

       

    End If

   Application.ScreenUpdating = True

End Sub