Notifications
Clear all

VBA - Gerar Um Arquivo PDF de vários Excel

2 Posts
2 Usuários
0 Reactions
1,005 Visualizações
(@murilof93)
Posts: 1
New Member
Topic starter
 

Estou tentando fazer um código para gerar um PDF para cada arquivo Excel que eu tenho em uma pasta.
Primeiramente meu código gera um PDF cada arquivo excel e depois gera um PDF que seria a capa de todos esses arquivos.

O problema que estou tendo é que gera em arquivos separados, alguém tem ideia de como poderia gerar um arquivo de PDF somente?

Sub BatchOpenMultiplePSTFiles()

    Dim objShell As Object

    Dim objWindowsFolder As Object

    Dim strWindowsFolder As String

    Application.ScreenUpdating = False

    'Desliga Atualização de Tela

    Application.DisplayAlerts = False

    'Desliga Alertas

    'Select the specific Windows folder

    Caminho = ThisWorkbook.Path

    'Caminho do Arquivo

    Set objShell = CreateObject("Shell.Application")

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Selecione a pasta com os arquivos" _

    & "Excel que deseja transformar em PDF:", 0, "")

    If Not objWindowsFolder Is Nothing Then

    'Se não selecionar nada, não faz nada

       strWindowsFolder = objWindowsFolder.self.Path & ""

       Call ProcessFolders(strWindowsFolder)

       'Chama macro para gerar arquivos PDF

        Sheets("Capa e Índice").Visible = True

        'Aba selecionada para ser gerado pdf

        ActiveWorkbook.SaveAs Filename:=strWindowsFolder & "01-Capa.pdf"

        'Salva como pdf

        Sheets("Capa e Índice").Visible = False

        'Oculta Aba

        ChDir strWindowsFolder

        Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus

        'Abrir pasta selecionada

   End If

   ActiveWorkbook.SaveAs Filename:=Caminho & "XXX.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled

   'Salva documento com nome original

    Application.ScreenUpdating = True

    'Liga Atualização de tela

    Application.DisplayAlerts = True

    'Liga Alertas

    MsgBox "Arquivos criados com sucesso"

End Sub

Sub ProcessFolders(strPath As String)

    Dim objFileSystem As Object

    Dim objFolder As Object

    Dim objFile As Object

    Dim objExcelFile As Object

    Dim objWorkbook As Excel.Workbook

    Dim strWorkbookName As String


    Set objFileSystem = CreateObject("Scripting.FileSystemObject")

    Set objFolder = objFileSystem.GetFolder(strPath)

'Para cada arquivo xlsx é gerado um arquivo PDF

    For Each objFile In objFolder.Files

        strFileExtension = objFileSystem.GetExtensionName(objFile)

        If LCase(strFileExtension) = "xlsx" Then

           Set objExcelFile = objFile

           Set objWorkbook = Application.Workbooks.Open(objExcelFile.Path)


           strWorkbookName = Left(objWorkbook.Name, (Len(objWorkbook.Name) - Len(strFileExtension)) - 1)

           objWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strWorkbookName & ".pdf"


           objWorkbook.Close False

        End If

    Next


    'Gerar PDF para subpastas

    If objFolder.SubFolders.Count > 0 Then

       For Each objSubFolder In objFolder.SubFolders

           If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then

              ProcessFolders (objSubFolder.Path)

           End If

       Next

    End If

End Sub
 
Postado : 14/11/2018 10:48 am
Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 0
Illustrious Member
 

Murilo,

Boa tarde!

Seja muito bem vindo ao fórum.

Para aproveitar ao máximo o fórum e sempre manter o mesmo de forma organizada, sugiro ler os tópico da regras abaixo:
viewtopic.php?f=7&t=16757
viewtopic.php?f=7&t=203
viewtopic.php?f=7&t=7903
viewtopic.php?f=7&t=3841
viewtopic.php?f=7&t=12600
viewtopic.php?f=7&t=3371

Algumas solicitações especiais que pedimos, por gentileza, ficar atento:
1 - Não inserir no titulo de suas postagens expressões como Help, Ajuda, etc. O título deve ser um resumo da sua necessidade para que outras pessoas que tenham a mesma dúvida possam efetuar a pesquisa e achar como foi resolvido.
2 - Não insira em suas mensagens frases todas escritas em letras maiúsculas. Isso, na Internet, é compreendido como gritos e muitos usuários sequer respondem somente por esse fato!
3 - Insira sempre um arquivo exemplo compactado com .ZIP aqui mesmo no fórum. Existe, logo abaixo da caixa de mensagens, uma aba chamada "Adicionar um anexo" para essa finalidade. O arquivo exemplo deve ser pequeno, com apenas 5 linhas no máximo, compactado com .ZIP e ter o mesmo layout (nome do arquivo, nome das abas/guias/folhas, mesma linha/coluna onde os dados se iniciam) do arquivo original. Links de arquivos enviados para sites de compartilhamento de arquivos, muitas vezes são bloqueados pelas empresas, por conterem muitos vírus. Alguns usuários que acessam o fórum a partir de empresas não conseguem baixar tais arquivos.
4 - Não utilize a ferramenta CITAR para inserir o inteiro teor das mensagens que lhe são encaminhadas como resposta. Citações, se estritamente necessárias ao entendimento da mensagem que você quer enviar, devem ser apenas de pequenos trechos das mensagens.
5 - Se for postar códigos VBA aqui no fórum, utilize a ferramenta CODE localizada logo no início da caixa de mensagens (quinto botão da esquerda para a direita). As linhas de código devem ficar entre as palavras "CODE e /CODE".
6 - Agradeça sempre às pessoas que lhe responderam e às mensagens que atenderam a necessidade de sua demanda. Esse agradecimento deve ser clicando na mãozinha que fica localizada ao lado da ferramenta CITAR. Lembre-se: o fórum é gratuito e esse é o único incentivo para as pessoas que prestam ajuda. Você pode agradecer a quantos usuários quiser.
7 - O título ou o texto das mensagens postadas não devem ser escritos todo em letras maiúsculas. Na internet, tudo escrito em letras maiúsculas é interpretado como gritos e muitos usuários sequer olham para esse tipo de mensagem.

Desenvolvo pequenas soluções em VBA Excel a valores que variam entre R$ 50,00 a R$ 200,00. Se te interessar, entre no meu instagran (vba_excel_desenvolvimento)

Atenciosamente
Wagner Morel

 
Postado : 14/11/2018 10:51 am