Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Preencher TXT a partir de Matriz Variável

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

Re: Preencher TXT a partir de Matriz Variável

Mensagem por Adonias »

Reinado, tentei de tudo, mas não tenho tanto conhecimento ainda.
Entrei no fórum do mrexcel, mas um membro me deu uma dica pelos comando dir, só que complicou ainda mais.
Não consegui.
Quem puder ajudar, por favor.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Preencher TXT a partir de Matriz Variável

Mensagem por Reinaldo »

Experimente

Código: Selecionar todos

Dim NovaPasta As String
Private Sub CriarCaminho()
'Obtem o diretorio a ser salvo
With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            NovaPasta = .SelectedItems(1)
        Else
            MsgBox ("Nenhum diretorio selecionado, será mantido o diretorio inicial")
        End If
End With
End Sub

Private Sub btCriar_Click()
Dim Linha As Long
Dim NomeDir As String, Caminho As String
Dim strTemp As String, strPath As String
Dim fsoLocal As Object
Dim msgResp As VbMsgBoxResult

strTemp = Cells(1, "AA").Value
If strTemp <> "" Then msgResp = MsgBox("O Diretorio Atual é:" & strTemp & " Deseja mante-lo??", vbYesNo)
If msgResp <> 6 Then CriarCaminho
If strTemp <> "" And NovaPasta = "" Then
    Caminho = strTemp
ElseIf NovaPasta <> "" Then
    Caminho = NovaPasta
    Cells(1, "AA").Value = NovaPasta
End If
Set fsoLocal = CreateObject("scripting.filesystemobject")
'Inicia o loop na linha 1 da coluna "A" (1) - Altere se necessario
For Linha = 1 To Range("A1").End(xlDown).Row
    If VBA.Right(Caminho, 1) <> "\" Then Caminho = Caminho & "\"
    NomeDir = VBA.Replace(VBA.Replace(VBA.Replace(Cells(Linha, 1).Value, "/", ""), ".", ""), "-", "")
    If VBA.Right(NomeDir, 1) <> "\" Then NomeDir = NomeDir & "\"
    strPath = Caminho & NomeDir
    If fsoLocal.FolderExists(strPath) Then
    Else
        fsoLocal.CreateFolder (Caminho & NomeDir)
        CopyFilesInFolder (Caminho & NomeDir)
    End If
Next
End Sub

Private Sub btLimpar_Click()
Range("A1:d1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
Range("a1").Value = "Cole Aqui"
Range("a1").HorizontalAlignment = xlCenter
End Sub

Private Function CopyFilesInFolder(Byval Destino as string)
'https://www.rondebruin.nl/win/s3/win026.htm
'This example copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
'Diretorio/Pasta de Origem
FromPath = "C:\Temp"  '<< Altere se necessario
'Diretorio/pasta de Destino    
ToPath = Destino

'Seleciona/determina arquivo
'You can use *.xl* for Excel files or *.doc for Word files
'"*.*" for All Files
FileExt = "*.*"  '<< Altere quando necessario

If Right(FromPath, 1) <> "\" Then FromPath = FromPath & "\"

Set FSO = CreateObject("scripting.filesystemobject")
'Se pasta de origem não for encontrada exibe mensagem e sai da rotina
If FSO.FolderExists(FromPath) = False Then
   MsgBox FromPath & " doesn't exist"
   Exit function
End If
'Se pasta de destino não for encontrada exibe mensagem e sai da rotina
If FSO.FolderExists(ToPath) = False Then
   MsgBox ToPath & " doesn't exist"
   Exit function
End If

    FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
   ' MsgBox "Os Arquivos de " & FromPath & " foram copiados para " & ToPath
End Function


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

[RESOLVIDO]Re: Preencher TXT a partir de Matriz Variável

Mensagem por Adonias »

Reinaldo, mais uma vez você foi brilhante.
Era exatamente o que eu precisava, MUITO OBRIGADO!!
e até a próxima, pois o aprender nunca finda.


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

Re: Preencher TXT a partir de Matriz Variável

Mensagem por Adonias »

Reinaldo, tentei de tudo, mas não consigo copiar para dentro das pastas criadas.
Cria as pastas e copia todos os arquivos da origem dentro da pasta principal de destino, mas nao dentro das pastas criadas nessas pasta principal.

Poderia dizer onde está o erro?
Anexos
CriarDiretorio.zip
(25.59 KiB) Baixado 168 vezes


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Preencher TXT a partir de Matriz Variável

Mensagem por Reinaldo »

Sem testar experimente

Código: Selecionar todos

Private Sub btCriar_Click()
Dim Linha As Long
Dim NomeDir As String, Caminho As String
Dim strTemp As String, strPath As String
Dim fsoLocal As Object
Dim msgResp As VbMsgBoxResult

strTemp = Cells(1, "AA").Value
If strTemp <> "" Then msgResp = MsgBox("O Diretorio Atual é:" & strTemp & " Deseja mante-lo??", vbYesNo)
If msgResp <> 6 Then CriarCaminho
If strTemp <> "" And NovaPasta = "" Then
    Caminho = strTemp
ElseIf NovaPasta <> "" Then
    Caminho = NovaPasta
    Cells(1, "AA").Value = NovaPasta
End If
Set fsoLocal = CreateObject("scripting.filesystemobject")
'Inicia o loop na linha 1 da coluna "A" (1) - Altere se necessario
For Linha = 1 To Range("A1").End(xlDown).Row
    If VBA.Right(Caminho, 1) <> "\" Then Caminho = Caminho & "\"
    NomeDir = VBA.Replace(VBA.Replace(VBA.Replace(Cells(Linha, 1).Value, "/", ""), ".", ""), "-", "")
    If VBA.Right(NomeDir, 1) <> "\" Then NomeDir = NomeDir & "\"
    strPath = Caminho & NomeDir
    If fsoLocal.FolderExists(strPath) Then

    Else
        fsoLocal.CreateFolder (Caminho & NomeDir)
        Copy_Folder (Caminho & NomeDir)
    End If
Next
End Sub
Private Sub Copy_Folder(ByVal strLocal As String)
'Este exemplo copia todos os arquivos da subpasta FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String

FromPath = "C:\Users\ADONIAS\Downloads\VBA\Model\"  '<< Change

If strLocal <> "" Then
    ToPath = strLocal
Else
    ToPath = "C:\Users\ADONIAS\Downloads\VBA\ModelOne\"    '<< Change
End If
If Right(FromPath, 1) = "\" Then
    FromPath = Left(FromPath, Len(FromPath) - 1)
End If

If Right(ToPath, 1) = "\" Then
    ToPath = Left(ToPath, Len(ToPath) - 1)
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "Você pode encontrar os arquivos da Subpasta " & FromPath & " Em " & ToPath
End Sub


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

[RESOLVIDO]Re: Preencher TXT a partir de Matriz Variável

Mensagem por Adonias »

Reinaldo, agora funcionou direitinho. Muito obrigado
Estou muito empolgado com VBA e cada dia aprendendo mais coisas aqui com Vocês.
Estou e


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder