- 18 Mai 2020 às 17:44
#54923
Tudo bom Pessoal ?
Venho solicitar a ajuda de vocês amigos e estou procurando meu erro, Quero transferir arquivos físicos de um diretório para o outro , porem só consigo se eu colocar uma extensão fixa.
Não estou conseguindo transferir quando se tem mais de uma extensão, existe essa possibilidade e onde estou errando ?
Segue Macro..
Public Function ListaArquivos(ByVal Caminho As String) As String()
'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim result() As String
Dim Pasta As Folder
Dim Arquivo As File
Dim Indice As Long
ReDim result(0) As String
If fso.FolderExists(Caminho) Then
Set Pasta = fso.GetFolder(Caminho)
For Each Arquivo In Pasta.Files
Indice = IIf(result(0) = "", 0, Indice + 1)
ReDim Preserve result(Indice) As String
result(Indice) = Arquivo.Name
Next
End If
ListaArquivos = result
ErrHandler:
Set fso = Nothing
Set Pasta = Nothing
Set Arquivo = Nothing
End Function
Sub ListarArquivos()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' /// Executar esse Sub chamando a Function ListaArquivos
Dim arquivos() As String
Dim lCtr As Long
' /// Mude o caminho Origem aqui
arquivos = ListaArquivos(Sheets("Transportar").Range("D3")) 'Caminho Origem sem Barra
Worksheets.Add
ActiveSheet.Name = "Mapa"
For lCtr = 0 To UBound(arquivos)
Cells(lCtr + 1, 1) = arquivos(lCtr)
Next
Dim Origem, Destino As String, ulin As Integer
ulin = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ulin
If Right$(Cells(i, 1), 4) = "*.*" Then ' PESSOAL POSSO ESTAR ERRANDO AQUI
' /// Mude o caminho Origem aqui
Origem = Sheets("Transportar").Range("D4") & Cells(i, 1).Value 'CAMINHO COM BARRA
' /// Mude o caminho Destino aqui
Destino = Sheets("Transportar").Range("D5") & Cells(i, 1).Value 'CAMINHO COM BARRA
FileCopy Origem, Destino
Else
MsgBox "Pasta sem Arquivo!", vbCritical, "Julio Mangilli."
Sheets("Mapa").Delete
Exit Sub
End If
Next
Kill Sheets("Transportar").Range("F4") 'CAMINHO COM BARRA EXTENSÃO COM CARACTER CHAVE *.*
Sheets("Mapa").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Arquivos Movido com Sucesso!", , "Julio Mangilli."
End Sub
Venho solicitar a ajuda de vocês amigos e estou procurando meu erro, Quero transferir arquivos físicos de um diretório para o outro , porem só consigo se eu colocar uma extensão fixa.
Não estou conseguindo transferir quando se tem mais de uma extensão, existe essa possibilidade e onde estou errando ?
Segue Macro..
Public Function ListaArquivos(ByVal Caminho As String) As String()
'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim result() As String
Dim Pasta As Folder
Dim Arquivo As File
Dim Indice As Long
ReDim result(0) As String
If fso.FolderExists(Caminho) Then
Set Pasta = fso.GetFolder(Caminho)
For Each Arquivo In Pasta.Files
Indice = IIf(result(0) = "", 0, Indice + 1)
ReDim Preserve result(Indice) As String
result(Indice) = Arquivo.Name
Next
End If
ListaArquivos = result
ErrHandler:
Set fso = Nothing
Set Pasta = Nothing
Set Arquivo = Nothing
End Function
Sub ListarArquivos()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' /// Executar esse Sub chamando a Function ListaArquivos
Dim arquivos() As String
Dim lCtr As Long
' /// Mude o caminho Origem aqui
arquivos = ListaArquivos(Sheets("Transportar").Range("D3")) 'Caminho Origem sem Barra
Worksheets.Add
ActiveSheet.Name = "Mapa"
For lCtr = 0 To UBound(arquivos)
Cells(lCtr + 1, 1) = arquivos(lCtr)
Next
Dim Origem, Destino As String, ulin As Integer
ulin = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ulin
If Right$(Cells(i, 1), 4) = "*.*" Then ' PESSOAL POSSO ESTAR ERRANDO AQUI
' /// Mude o caminho Origem aqui
Origem = Sheets("Transportar").Range("D4") & Cells(i, 1).Value 'CAMINHO COM BARRA
' /// Mude o caminho Destino aqui
Destino = Sheets("Transportar").Range("D5") & Cells(i, 1).Value 'CAMINHO COM BARRA
FileCopy Origem, Destino
Else
MsgBox "Pasta sem Arquivo!", vbCritical, "Julio Mangilli."
Sheets("Mapa").Delete
Exit Sub
End If
Next
Kill Sheets("Transportar").Range("F4") 'CAMINHO COM BARRA EXTENSÃO COM CARACTER CHAVE *.*
Sheets("Mapa").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Arquivos Movido com Sucesso!", , "Julio Mangilli."
End Sub
