Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E
Preencher TXT a partir de Matriz Variável
Re: Preencher TXT a partir de Matriz Variável
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.
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.
- Reinaldo
- 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
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
[RESOLVIDO]Re: Preencher TXT a partir de Matriz Variável
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.
Era exatamente o que eu precisava, MUITO OBRIGADO!!
e até a próxima, pois o aprender nunca finda.
Re: Preencher TXT a partir de Matriz Variável
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?
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
- Reinaldo
- 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
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
[RESOLVIDO]Re: Preencher TXT a partir de Matriz Variável
Reinaldo, agora funcionou direitinho. Muito obrigado
Estou muito empolgado com VBA e cada dia aprendendo mais coisas aqui com Vocês.
Estou e
Estou muito empolgado com VBA e cada dia aprendendo mais coisas aqui com Vocês.
Estou e