Tópicos relacionados a códigos VBA, gravação de macros, etc.
  • Avatar do usuário
Por arthurvalenca
#61660
:roll: Olá a todos estou batendo a cabeça aqui para criar um script que crie uma pasta raiz chamada "Save", logo após dentro da pasta Save crie outra pasta com o nome que estiver na coluna A1, apos criar essa crie outras pasta dentro da pasta que foi criada com o nome da coluna A1 chamada "info" e por fim salve a planilha aberta nessa pasta info com o nome da coluna A1, alguém poderia me ajudar com esse código?

OBS: As duas primeiras pastas que seria as duas primeira funções funcionam bem, mas a terceira e ultima nao funcionam.

Segue abaixo o que eu estou tentando fazer:
Código: Selecionar todos
Sub CriarPastas()

'Cria a pasta Raiz aonde esta a pasta de trabalho
     
    Dim raiz As Object, save
        Set raiz = CreateObject("Scripting.FileSystemObject")

            On Error Resume Next

                save = ThisWorkbook.Path & "\" & "Save"

    If Not raiz.folderexists(save) Then
            raiz.createFolder (save)
    End If
    
    
'Cria a pasta com o nome da celula A1 dentro da pasta Save
    
    Dim sub_p As Object, subPasta
        Set sub_p = CreateObject("Scripting.FileSystemObject")

            On Error Resume Next

                subPasta = save & "\" & Planilha1.Range("A1").Text

    If Not sub_p.folderexists(subPasta) Then
        sub_p.createFolder (subPasta)
    End If

'Cria uma pasta chamada info dentro da pasta criada com o nome da celula A1

    Dim sub_p1 As Object, subPasta1
        Set sub_p1 = CreateObject("Scripting.FileSystemObject")

            On Error Resume Next

                subPasta1 = save & "\" & subPasta1 & "\" & "info"

    If Not sub_p1.folderexists(subPasta1) Then
        sub_p1.createFolder (subPasta1)
    End If

'Salva em txt dentro da pasta info

    Dim Nome As String
    
     Nome = Planilha1.Range("A1").Text
     ActiveWorkbook.SaveAs Filename:=save & "\" & "subPasta" & "\" & subPasta1 & "\" & Nome & ".txt", _
     FileFormat:=xlUnicodeText, CreateBackup:=False


End Sub
Avatar do usuário
Por AfonsoMira
#61670
Boas veja se é isto que deseja:
Código: Selecionar todos
Sub CriarPastas()

'Cria a pasta Raiz aonde esta a pasta de trabalho
     
    Dim raiz As Object, save
        Set raiz = CreateObject("Scripting.FileSystemObject")

            On Error Resume Next

                save = ThisWorkbook.Path & "\" & "Save"

    If Not raiz.folderexists(save) Then
            raiz.createFolder (save)
    End If
    
    
'Cria a pasta com o nome da celula A1 dentro da pasta Save
    
    Dim sub_p As Object, subPasta
        Set sub_p = CreateObject("Scripting.FileSystemObject")

            On Error Resume Next

                subPasta = save & "\" & ActiveSheet.Range("A1").Text

    If Not sub_p.folderexists(subPasta) Then
        sub_p.createFolder (subPasta)
    End If

'Cria uma pasta chamada info dentro da pasta criada com o nome da celula A1

    Dim sub_p1 As Object, subPasta1
        Set sub_p1 = CreateObject("Scripting.FileSystemObject")

            On Error Resume Next

                subPasta1 = subPasta & "\info"

    If Not sub_p1.folderexists(subPasta1) Then
        sub_p1.createFolder (subPasta1)
    End If

'Salva em txt dentro da pasta info

    Dim Nome As String
    
     Nome = ActiveSheet.Range("A1").Text
     ActiveWorkbook.SaveAs Filename:=subPasta1 & "\" & Nome & ".txt", _
     FileFormat:=xlUnicodeText, CreateBackup:=False

End Sub
arthurvalenca agradeceu por isso
Procurar valor em um texto

=ESQUERDA(V2;LOCALIZAR(",";V2)-1) Conseg[…]

cont.se com ext.texto

Bom dia, Estou tentando unir as fórmula[…]

Ventura , Bom dia. Obrigado pelo feedback. Fico[…]

thaisdoo , Bom dia. Obrigado pelo feedback. Fic[…]

Você não esta conseguindo porque os […]

Ajuda com botões em linhas.

Veja se esta solução ajuda. Funcion[…]

Segue uma ideia. Aplique Formataçã[…]

Boa tarde, AfonsoMira. Funciona sim... Muito obri[…]