Via une liste excel transférer des fichiers dans un dossier windows

jipi06

XLDnaute Junior
Bonsoir

par VBA, je souhaite transférer/dispatcher les fichiers listés dans une feuille excel sur la colonne B dans le dossiers correspondants listés dans la colonne A.

J'ai plusieurs centaines de fichiers à dispatcher et j'aimerai le faire d'un coup !

Les fichiers à transférer sont stockés dans un dossier nommé TOTAL situé au même niveau d'arborescence que les dossiers listés dans la colonne A.

La feuille excel comportant ces infos est stockée au même endroit.

Je joint un fichier exemple.

Merci de votre aide

jipi06
 

Fichiers joints

sousou

XLDnaute Accro
bonjour
ici un code à tester . pense à mettre le chemin de ton arborescence à la place de' ici le chemin'
Sub deb()
chemin = "ici le chemin" & "\"
drlg = dernièrelg(Sheets("transfert"), 2)
Set fso = CreateObject("scripting.filesystemobject")

With Sheets("transfert")
For n = 2 To drlg
Set fich = fso.getfile(chemin & "total\" & .Cells(n, 2))
fich.Move (chemin & .Cells(n, 1) & "\")
Next
End With
End Sub
'calcule la dernière ligne de la base
'feuille=objetfeuille, col= numéro de colonne, ligne ligne de départ)
Function dernièrelg(feuille, col, Optional lgd As Integer = 1)

With feuille
Set k = .Cells(.UsedRange.Columns(col).Rows.Count + 1 + lgd, col).End(xlUp)
If k <> "" Then dernièrelg = k.Row + 1 Else dernièrelg = 1
End With
End Function
 

job75

XLDnaute Barbatruc
Bonsoir jipi06, sousou,
Code:
Sub Transfert()
Dim dossier1$, dossier2$, fso As Object, tablo, i&
dossier1 = ThisWorkbook.FullName
dossier1 = Left(dossier1, InStrRev(dossier1, "\") - 1)
dossier2 = Left(dossier1, InStrRev(dossier1, "\"))
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
tablo = Sheets("Transfert").UsedRange.Resize(, 2)
For i = 2 To UBound(tablo)
    fso.movefile dossier1 & "\" & tablo(i, 2), dossier2 & tablo(i, 1) & "\" & tablo(i, 2)
Next
End Sub
Le fichier de la macro doit être dans le même dossier (TOTAL) que les fichiers de la colonne B.

A+
 

Discussions similaires


Haut Bas