Ranger/déplacer des fichiers dans des dossiers spécifiques

Question

Je suis débutant en vba. Je souhaite déplacer/ranger (déclenchement manuel) un nombre important de documents (environs 5000) dans dossiers spécifiques. j'ai un fichier excel (qui contient plusieurs feuils) dont une feuil portant le nom de "tag_fichiers_dossiers", celle-ci contient 2 colonnes déjà renseignées : - colonne "A" contient les noms de mes fichiers (avec extensions différentes : .pdf, .xls. doc...). Ces fichiers sont stockés dans mon local "mes documents\documents_a_ranger" - colonne "B" contient le chemin vers les dossiers où chaque fichier doit être déposé. Une partie, sont des liens SharePoint que j'ai copié manuellement (il y a environs 100 dossiers, je n'ai pas trouvé le moyen de générer automatiquement les liens vers ces dossiers sous forme de liste) et l'autre partie sont des lignes vers des dossiers en local. je cherche a créer une macro qui permet pour chaque ligne du tableau : - vérifier si le fichier existe dans le dossier de destination. Si il existe alors le fichier existant devra être supprimé et remplacé par le nouveau. - pour chaque ligne du tableau, déplacer (fonction de couper et non copier) le fichier portant le nom indiqué en colonne A dans le dossier qui est accessible suivant le lien SharePoint en colonne B. - compléter la colonne C en indiquant "Rangement fait" ou "Rangement NOK" afin d'identifier ceux qui n'ont pas été rangé. Merci bcp pour votre aide. Cordialement...

Geof52 · Answer

Pour être raccord, tu devrais poster un exemple de ton fichier sans données perso. Vite fait comme ça tu auras besoin de : MkDir (chemin_du_dossier) 'qui va te creer le dossier s'il n'existe pas Set FSO = CreateObject("Scripting.FileSystemObject") FSO.MoveFolder / FSO.MoveFile / FSO.DeleteFolder 'Qui va deplacer le dossier/fichier ou le supprimer A+...

Geof52 · Answer

Pour les dossiers SharePoint, les liens ne vont pas fonctionner dans l'état.

J'ai commencé a transformer le lien mais pas sur de mon coup donc j'ai laissé en commentaire le déplacement du fichier.

A tester

Sub Classement_Test()

Dim FSO As Object
Dim Doc_A_Ranger As String
Dim Doc_Dest As String
Dim Fic_A_Ranger As String
Dim Lig_Total As Integer

Set FSO = CreateObject("Scripting.FileSystemObject")
Doc_A_Ranger = "C:\Users\PK201\OneDrive - espace1\Documents\documents_a_ranger\"

Lig_Total = Cells(Rows.Count, 1).End(xlUp).Row
For Lig = 2 To Lig_Total
    Fic_A_Ranger = Cells(Lig, 1)
    Doc_Dest = Cells(Lig, 2)
    'doc local
    If Left(Doc_Dest, 1) = "C" Then
        If Right(Doc_Dest, 1) <> "\" Then Doc_Dest = Doc_Dest & "\"
        FSO.MoveFile Doc_A_Ranger & Fic_A_Ranger, Doc_Dest & Fic_A_Ranger
        Cells(Lig, 3).Value = "Ok rangé"
    Else
    'doc SharePoint
        Doc_Dest = Replace(Doc_Dest, "/", "\")
        Doc_Dest = Replace(Doc_Dest, "https:", "")
        Doc_Dest = Replace(Doc_Dest, ".com\", ".com@SSL\")
        Doc_Dest = Replace(Doc_Dest, "%20", " ")
'        Doc_Dest = Replace(Doc_Dest, "%26", "-")

'        FSO.MoveFile Doc_A_Ranger & Fic_A_Ranger, Doc_Dest & Fic_A_Ranger

        Cells(Lig, 3).Value = "Lien a modifier ?"
    End If
Next
End Sub

JFL · Answer

Pour votre information, la demande est multi-postée...

Geof52 · Answer

J'ai rajouté les lignes si le dossier destinataire n'existe pas et si le fichier a ranger n'existe pas.

J'ai aussi supprimé la partie du sharepoint du coup a tester (normalement il ne va pas trouver le dossier destination donc mettre dossier non trouvé)

Sub Classement_Test()

Dim FSO As Object
Dim Doc_A_Ranger As String
Dim Doc_Dest As String
Dim Fic_A_Ranger As String
Dim LienFichier As String
Dim Lig_Total As Integer

Set FSO = CreateObject("Scripting.FileSystemObject")
Doc_A_Ranger = "C:\Users\PK201\OneDrive - espace1\Documents\documents_a_ranger\"
If Right(Doc_A_Ranger, 1) <> "\" Then Doc_A_Ranger = Doc_A_Ranger & "\"

Lig_Total = Cells(Rows.Count, 1).End(xlUp).Row
For Lig = 2 To Lig_Total
    Fic_A_Ranger = Cells(Lig, 1)
    Doc_Dest = Cells(Lig, 2)
    If Right(Doc_Dest, 1) <> "\" Then Doc_Dest = Doc_Dest & "\"

    'Verif dossier destination
    If Dir(Doc_Dest, vbDirectory) = vbNullString Then
        Cells(Lig, 3).Value = "Dossier non trouvé"
        GoTo Lignesuivante
    End If
    'Verif Fichier a ranger
    LienFichier = Doc_A_Ranger & Fic_A_Ranger
    If Len(Dir(LienFichier)) > 0 Then
        Else
        Cells(Lig, 3).Value = "Fichier non trouvé"
        GoTo Lignesuivante
    End If

    'dos local
    If Left(Doc_Dest, 1) = "C" Then
        FSO.MoveFile Doc_A_Ranger & Fic_A_Ranger, Doc_Dest & Fic_A_Ranger
        Cells(Lig, 3).Value = "Ok rangé"
    End If
Lignesuivante:
Next
End Sub

Il faut savoir que je test si dans la colonne B le lien commence par "C" (dossier local C:\) avec :

    If Left(Doc_Dest, 1) = "C" Then
....
    end if

pour pouvoir le classer donc il faudra peut etre supprimer cette ligne ainsi que le End if vu qu'il n'y a plus de sharepoint.

Pour le message de JFL effectiment suivant la charte, il ne faut pas poster sur plusieurs forum car les "aidants" peuvent perdre leurs temps a répondre a quelqu'un qui a déja une solution.

Charte : https://forum.excel-pratique.com/excel/a-lire-avant-de-poster-charte-du-forum-et-informations-utiles...