Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Salvar em pasta esp...
 
Notifications
Clear all

Salvar em pasta especifica

 
2024 - VBA & Macros
Post Recente por MPrudencio 9 anos atrás
6 Posts
3 Usuários
0 Reactions
1,560 Visualizações
RSS
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
Topic starter
 

Boa tarde, me surgiu uma pequena necessidade que é salvar o arquivo pdf em uma pasta específica de acordo com um critério.

Salvar em pdf não é o problema, o problema e a levar isso para a pasta desejada.

Sendo mais específico tenho uma pasta em C que salva meus pedidos e dentro desta pasta quero colocar mais 12 pastas 1 pra cada mês e salvar na pasta do mês corrente.

Pensei em declarar uma variável só que não consegui coloca-la no código para atingir o objetivo. Estou do cel mas se precisarem coloco um código mais tarde que salve o arquivo como utilizo hj.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 11/01/2016 3:20 pm
 messiasmbm
(@messiasmbm)
Posts: 223
Estimable Member
 

Function Abre_Pasta()

MsgBox ("Eu vou abrir o Windows Explorer para voce selecionar a pasta onde encontra-se o arquivo!")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Por Favor selecione a Pasta", 0, "C:")
If (Not objFolder Is Nothing) Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then diretorio = CStr(objFolder): GoTo Here
On Error GoTo 0
If Len(objFolder.Items.Item.Path) > 3 Then
diretorio = objFolder.Items.Item.Path & Application.PathSeparator
Else
diretorio = objFolder.Items.Item.Path
End If
Else
MsgBox "Cancelado pelo Usuário !": End
End If

Here:
MsgBox "Voce selecionou a pasta -> " & diretorio, vbInformation, "ObjectFolder:= " & objFolder

Set objFolder = Nothing
Set objShell = Nothing

End Function
 
Postado : 11/01/2016 5:42 pm
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Uma vez que ja tem a rotina para salvar em PDF, fiquei na duvida se pretende fazer conforme a rotina indicada pelo messias, onde abrirá a cx de dialogo para selecionar a pasta ou criar uma nova, ou criar a mesma se ele não existir direto na rotina.
De qualquer forma de uma olhada no link abaixo se ajuda, tem até um exemplo para baixar, veja se consegue ajustar.

Criar pastas automaticamente com VBA
http://guiadoexcel.com.br/criar-pastas- ... te-com-vba

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 11/01/2016 9:43 pm
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
Topic starter
 

Bom dia acho que nao me fiz entender... (as duas soluções ja estao guardadas para uso futuro)

O codigo abaixo (é um exemplo, mas funciona exatamente como o original), salva na pasta C:Backup o PDF gerado, eu preciso alterar o codigo para que salve em C:BackupMES ATUAL, ou seja esse mes C:BackupJaneiro, e no mes que que vem C:BackupFevereiro e assim por diante.

As pastas ja Existem so preciso adequar para salvar na pasta correta.

Sub PDF()

Dim Data As Date
Dim Wbd, Wrel As Worksheet
Dim W As Workbook
Dim Arq As String

Application.ScreenUpdating = False

Set Wbd = Sheets("BANCO DE DADOS VOOS")
Set Wrel = Sheets("Relatorio")
Set W = Workbooks("Desacoplagem NOVA")
    Data = Wbd.Range("D3").Value
    Arq = "Relatorio" & " - " & Format(Data, "DD.MM.YYYY")
    

                                 Wrel.Select
                     Wrel.Range("A5").Select
                        Wrel.Range(Selection, _
            Selection.End(xlToRight)).Select
                        Wrel.Range(Selection, _
               Selection.End(xlDown)).Select
                     Selection.ClearContents
                     
        Wrel.Range("A5").Select

    Wbd.Select
    Wbd.Range("A11").Select

Do While ActiveCell <> ""

If ActiveCell = Data Then

                                 Range(Selection, _
                Selection.End(xlToRight)).Select
                                  Selection.Copy
                               
         Wrel.Select
         
         Wrel.Range("A1048576").End(xlUp).Select
                  ActiveCell.Offset(1, 0).Select
                          Selection.PasteSpecial _
                            Paste:=xlPasteValues
                 
                  ActiveCell.Offset(1, 0).Select
        
    Application.CutCopyMode = False

                                      Wbd.Select
                  ActiveCell.Offset(1, 0).Select

Else

                  ActiveCell.Offset(1, 0).Select

End If

Loop

Wrel.Select
Wrel.Range("A5").Select

    ChDir "C:Backup"

    Wrel.ExportAsFixedFormat Type:=xlTypePDF, _
       Filename:="C:Backup" & Arq & ".pdf", _
                   Quality:=xlQualityMinimum, _
                  IncludeDocProperties:=True, _
                     IgnorePrintAreas:=False, _
                     OpenAfterPublish:=False

                     Wrel.Range("A5").Select
                     Wbd.Select
                     Wbd.Range("A11").Select
    
  MsgBox "Relatorio Salvo com Sucesso", _
                              vbOKOnly, _
                              "Relatorio de Voos"
        
    Application.ScreenUpdating = True
    
    W.Save
    
End Sub

Aguardo

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 12/01/2016 8:59 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Experimente:

Sub PDF()

Dim Data As Date
Dim Wbd As Worksheet, Wrel As Worksheet
Dim W As Workbook
Dim Arq As String

Application.ScreenUpdating = False

Set Wbd = Sheets("BANCO DE DADOS VOOS")

Set Wrel = Sheets("Relatorio")
Set W = Workbooks("Desacoplagem NOVA")
    Data = Wbd.Range("D3").Value
    Arq = "Relatorio" & " - " & Format(Data, "DD.MM.YYYY")
    

                                 Wrel.Select
                     Wrel.Range("A5").Select
                        Wrel.Range(Selection, _
            Selection.End(xlToRight)).Select
                        Wrel.Range(Selection, _
               Selection.End(xlDown)).Select
                     Selection.ClearContents
                     
        Wrel.Range("A5").Select

    Wbd.Select
    Wbd.Range("A11").Select

Do While ActiveCell <> ""

If ActiveCell = Data Then

                                 Range(Selection, _
                Selection.End(xlToRight)).Select
                                  Selection.Copy
                               
         Wrel.Select
         
         Wrel.Range("A1048576").End(xlUp).Select
                  ActiveCell.Offset(1, 0).Select
                          Selection.PasteSpecial _
                            Paste:=xlPasteValues
                 
                  ActiveCell.Offset(1, 0).Select
        
    Application.CutCopyMode = False

                                      Wbd.Select
                  ActiveCell.Offset(1, 0).Select

Else

                  ActiveCell.Offset(1, 0).Select

End If

Loop

Wrel.Select
Wrel.Range("A5").Select

'Informa o caminho
Dim sPath As String, sMesExt As String
Path = "C:Backup"
sMesExt = Format(Data, "mmmm")

If Right(sPath, 1) <> "" Then sPath = sPath & "" & sMesExt
If Right(sPath, 1) <> "" Then sPath = sPath & ""

'Verifica se o diretorio existe, se não existir, cria
    If (Dir(sPath, vbDirectory) = "") Then
        MkDir (sPath)
    End If

'Verifica se o arquivo já existe, se existir, deleta
Arq = sPath & Arq & ".pdf"
    If (Dir(Arq) <> "") Then
        Kill Arquivo
    End If
'Salva copia do arquivo no caminho especificado
    
    
    
    ChDir "C:Backup"

    Wrel.ExportAsFixedFormat Type:=xlTypePDF, _
       Filename:=Arq, _
                   Quality:=xlQualityMinimum, _
                  IncludeDocProperties:=True, _
                     IgnorePrintAreas:=False, _
                     OpenAfterPublish:=False

                     Wrel.Range("A5").Select
                     Wbd.Select
                     Wbd.Range("A11").Select
    
  MsgBox "Relatorio Salvo com Sucesso", _
                              vbOKOnly, _
                              "Relatorio de Voos"
        
    Application.ScreenUpdating = True
    
    W.Save
    
End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 12/01/2016 12:23 pm
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
Topic starter
 

Reinado obrigado pela ajuda esta quase la. Mas com uns pequenos ajustes o objetivo foi alcançado.

Obrigado

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 12/01/2016 4:27 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico