none
CRIAR UMA PASTA NO DESKTOP E SALVAR PLANILHA RRS feed

  • Pergunta

  • Teria uma forma de criar um botão com a função de abrir um imputbox renomear o arquivo atual e salvá-lo dentro de uma pasta criada pelo mesmo botão no ato do click?
    OBS: Mas quando usuário clicar outras vezes neste mesmo botão não crie outra pasta e armazene o novo arquivo na mesma sem salvar salvar cima da planilha salva anteriormente.

    *Consegui este código que cria uma pasta:

    MyFilePath$ = ActiveWorkbook.Path & "\" & _
                        Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
          With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                On Error Resume Next    '<< Se a folder existe
                MkDir MyFilePath            '<< se não cria uma nova
              
          End With

    *Este código abaixo cria uma backup da planilha:

    Sub SaveAndBackup()
        Dim strName As String, strMsg As String
        strMsg = "Please enter the Filename:"
        strName = ActiveWorkbook.FullName
        strName = InputBox(strMsg, , strName)
        If strName = "" Then Exit Sub
        ActiveWorkbook.SaveAs FileName:=strName, FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=True
    End Sub

    * OBS: O que eu queria era uma ajuda dos amigos. Usando estes códigos acima faz ação blz, mas o arquivo é claro cai fora da pasta. Alguém sabe mudar o path de destino do arquivo para que simplesmente tenha a mesma função porém após a ação do código o arquivo caia dentro da pasta. Resumindo preciso unir os dois códigos em um só

    Obrigado...

    Pablo Moreira

    • Editado Pablo Moreira quarta-feira, 4 de agosto de 2010 12:07 título errado
    quarta-feira, 4 de agosto de 2010 12:06

Respostas

  • Sub FazerBackup()
      
      Dim lng As Long
      Dim strPasta As String
      Dim strArquivo As String
      
      On Error Resume Next
      strPasta = RetiraExtensão(ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name)
      MkDir strPasta
      On Error GoTo 0
      Do
        lng = lng + 1
        strArquivo = RetiraExtensão(strPasta & Application.PathSeparator & ThisWorkbook.Name) & " " & Format(lng, "0000") & "." & MinhaExtensão(ThisWorkbook.Name)
      Loop While ArquivoExiste(strArquivo)
      ThisWorkbook.SaveCopyAs strArquivo
      
    End Sub
    
    Private Function RetiraExtensão(str As String) As String
      Dim ar As Variant
      
      ar = Split(str, ".")
      If UBound(ar) > 0 Then
        ReDim Preserve ar(UBound(ar) - 1)
      End If
      RetiraExtensão = Join(ar, ".")
    
    End Function
    
    Private Function MinhaExtensão(str As String) As String
      Dim ar As Variant
      
      ar = Split(str, ".")
      MinhaExtensão = ar(UBound(ar))
    
    End Function
    
    Private Function ArquivoExiste(strNomeArquivo) As Boolean
      ArquivoExiste = (Dir(strNomeArquivo) <> vbNullString)
    End Function
    sábado, 21 de agosto de 2010 01:30
    Moderador

Todas as Respostas

  • Tene fazer isso:

     

    • Você ja tentou usar o comando "shell", e coloca o comando que cria pastas pelo cmd dentro da função shell?
    • para salvar o documento, voce pode criar uma macro, e alterar o nome da pasta para uma variavel contendo o caminho da pasta criada.
    • E para que você salve apenas uma vez, crie uma variavel booleana, se ela for verdadeira salvar, caso seja falso nao salvar ou ao contrário tanto faz ^^
    quinta-feira, 5 de agosto de 2010 14:39
  • Tene fazer isso:

     

    • Você ja tentou usar o comando "shell", e coloca o comando que cria pastas pelo cmd dentro da função shell?
    • para salvar o documento, voce pode criar uma macro, e alterar o nome da pasta para uma variavel contendo o caminho da pasta criada.
    • E para que você salve apenas uma vez, crie uma variavel booleana, se ela for verdadeira salvar, caso seja falso nao salvar ou ao contrário tanto faz ^^


    Olha. Eu fiz algumas alterações juntando os dois códigos e ele tá criando uma pasta e salvando o documento dentro dela....blz.... O problema é que eu queria que o documento salvo passa a ser a original, sendo que o que queria era que salvasse dentro da pasta como está acontecendo e eu continuasse editando a planilha original.

    Segue código que está sendo usado:

    Sub SaveShtsAsBook()
       
        Dim strName As String, strMsg As String
        strMsg = "Please enter the Filename:"
        strName = ActiveWorkbook.FullName
        strName = InputBox(strMsg, , strName)
        If strName = "" Then Exit Sub

          Dim Sheet As Worksheet, MyFilePath$, N&
          MyFilePath$ = ActiveWorkbook.Path & "\" & _
                       Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
          With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                On Error Resume Next    '<< Se a folder existe
                MkDir MyFilePath            '<< se não cria uma nova
                For N = 1 To Sheets.Application
               
                      Sheets(N).Activate
                      strName = ActiveWorkbook.Name
                      With ActiveWorkbook
                            With .ActiveSheet
                                 .Name = strName
                               
                            End With
                          
            
                            'salva as planilhas nesta nova folder
                            .SaveAs Filename:=MyFilePath _
                                              & "\" & strName & ".xls", FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=True
                           
                 End With
                    
                Next
          End With
             
    End Sub

    quinta-feira, 5 de agosto de 2010 15:01
  • http://www.a1vbcode.com/a1vbcode/vbforums/Topic5891-3-1.aspx#bm5895

    Veja esta dica:http://www.freevbcode.com/ShowCode.asp?ID=1697


    Just Be Humble Malange!
    sexta-feira, 6 de agosto de 2010 10:11
  • http://www.a1vbcode.com/a1vbcode/vbforums/Topic5891-3-1.aspx#bm5895

    Veja esta dica:http://www.freevbcode.com/ShowCode.asp?ID=1697


    Just Be Humble Malange!


    Malange, blz!

              Cara me desculpe, mas eu não entedi nada, o link é esse mesmo? O site tá todo em inglês e não sei o que aquele código faz.

    Obrigado

    sexta-feira, 6 de agosto de 2010 10:53
  • Sub FazerBackup()
      
      Dim lng As Long
      Dim strPasta As String
      Dim strArquivo As String
      
      On Error Resume Next
      strPasta = RetiraExtensão(ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name)
      MkDir strPasta
      On Error GoTo 0
      Do
        lng = lng + 1
        strArquivo = RetiraExtensão(strPasta & Application.PathSeparator & ThisWorkbook.Name) & " " & Format(lng, "0000") & "." & MinhaExtensão(ThisWorkbook.Name)
      Loop While ArquivoExiste(strArquivo)
      ThisWorkbook.SaveCopyAs strArquivo
      
    End Sub
    
    Private Function RetiraExtensão(str As String) As String
      Dim ar As Variant
      
      ar = Split(str, ".")
      If UBound(ar) > 0 Then
        ReDim Preserve ar(UBound(ar) - 1)
      End If
      RetiraExtensão = Join(ar, ".")
    
    End Function
    
    Private Function MinhaExtensão(str As String) As String
      Dim ar As Variant
      
      ar = Split(str, ".")
      MinhaExtensão = ar(UBound(ar))
    
    End Function
    
    Private Function ArquivoExiste(strNomeArquivo) As Boolean
      ArquivoExiste = (Dir(strNomeArquivo) <> vbNullString)
    End Function
    sábado, 21 de agosto de 2010 01:30
    Moderador