Mover certos arquivos com o VBA

Question

Estou tentando mover todos os nossos arquivos diários de uma listagem no Excel. A coluna D tem a origem, D:\Hard drive\Lee’s Hard Drive\My Documents\WBD052U_PRINT01*.txt coluna E tem destino, C:\Users\Lee\Documents\Work. WBD52U

Quando executo a macro, recebo o seguinte erro

Run time error 13. Type mismatch.

Se eu fizer apenas 1 linha, por exemplo

FromPath Range(D5:D5) ToPath Range (E5:E5) 

isso funciona perfeitamente.

Assim que especificar um intervalo maior, isso não funciona. Obrigado eu realmente preciso de ajuda.

   Sub Move_Certain_Files()

Dim fso, MyFile
Dim FromPath As String
Dim ToPath As String


FromPath = ActiveSheet.Range("D5:D6") '<< Change
ToPath = ActiveSheet.Range("E5:E6")   '<< Change


On Error Resume Next
Kill FromPath = ActiveSheet.Range("D5:D6")
On Error GoTo 0


Set fso = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

fso.copyFile (FromPath), ToPath, True
MsgBox "File Copied to Destination Folder Successfully", vbInformation, "Done!"


fso.copyFile Source:=FromPath, Destination:=ToPath

On Error GoTo 0

End Sub

    

Answer 1

Esse erro ocorre porque você está tentando definir um intervalo para uma variável String (FromPath). Você precisaria configurá-lo para uma variável Range, usando Set. Vamos querer trabalhar em cada item desse intervalo. É mais fácil trabalhar com um único intervalo de coluna (podemos referenciar o material ao lado facilmente ao mesmo tempo). Além disso, em vez de trabalhar no intervalo para pegar e depois fazer o trabalho de cópia mais tarde, podemos fazer o trabalho de cópia diretamente enquanto trabalhamos no intervalo. Aqui vamos nós:

Sub Move_Certain_Files()

    Dim fso, MyFile
    Dim pathsRng As Range

    'Set range here, just the first [FROM path] column:
    Set pathsRng = ActiveSheet.Range("D5:D6")

    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next

    'Loop through paths range to copy from FROM path and paste
    'to TO path (TO path is found by using relative address (1, 2):
    For Each pathItem In pathsRng
        fso.CopyFile (pathItem.Value), pathItem(1, 2).Value, True
    Next pathItem

    'Display success/failure message:
    If Err.Number = 0 Then
        MsgBox "File(s) Copied to Destination Folder Successfully", vbInformation, "Done!"
    Else
        MsgBox "Error: Some files may not have copied.", vbInformation, "Done!"
    End If

    On Error GoTo 0

End Sub

Adicional: eu queria perguntar, não tenho certeza da sua intenção com a frase:

Kill FromPath = ActiveSheet.Range("D5:D6")

Deseja excluir os arquivos de origem após a cópia? Se assim for, você deve fazer isso depois de copiar usando um loop - OU você poderia simplesmente mover os arquivos ao invés de copiar: No meu código acima você mudaria a seguinte linha:

fso.CopyFile (pathItem.Value), pathItem(1, 2).Value, True

para isso:

fso.MoveFile (pathItem.Value), pathItem(1, 2).Value