Microsoft 365 VBA_Classement automatique des documents à partir d'un répertoire fixe vers répertoire variable

pulelian · 25 Juillet 2021

Bonsoir à tous !

Je souhaite archiver automatiquement mes documents à partir d'un répertoire fixe vers des répertoires variables selon le nom du document.

1- je récupère les documents postés dans le répertoire fixe sur la colonne A et B
2 - via des formules je découpe en colonne D,E,F et G
3 - Le code MoveFile est là pour partir du répertoire fixe et dispatcher les documents sur les différents répertoire

1er erreur : et bien cela ne fonctionne pas

. Les docs vont tous au même endroit quoiqu'il arrive...
2ième erreur : Je reste bloqué sur une erreur 76: chemin introuvable sans comprendre pourquoi lorsque je rajoute doss2 et doss3 pour xDPath

(ps: je n'ai pas eu la compétence d'écrire les codes, juste de les adapter = amateur !!!. Il s'agit de la récupération de code de généreuse personne actif sur les forums.)

VB:

Sub MoveFiles()

    Dim xFd As FileDialog
    Dim xTFile As String
    Dim xExtArr As Variant
    Dim xExt As Variant
    Dim xSPath As String
    Dim xDPath As String
    Dim xSFile As String
    Dim xCount As Long
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    
    NomEntreprise = "entreprisea"
    Lect = USBD
    SpecialPath = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN\Ranger"
    NomDossier = SpecialPath & "\"
    
      
       Dim doss, doss1, doss2, doos3 As String
 
      
      
       xSPath = NomDossier
        
'
    If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
    
    ''
    Set Plage = Sheets("Doc_2").Range("A1:A50")
    For Each cell In Plage
    If cell <> 0 Then
    
    
    doss = cell.Offset(0, 3).Value
    doss1 = cell.Offset(0, 4).Value
    doss2 = cell.Offset(0, 5).Value
    doss3 = cell.Offset(0, 6).Value

    MsgBox doss2
    
    SpecialPath2 = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN"
    NomDossier2 = SpecialPath2 & "\" & doss & "\" & doss1 & "\" & doss2 & "\" & doss3 & "\"
    

        xDPath = NomDossier2
        
    End If
    Next


    If Right(xDPath, 1) <> "\" Then xDPath = xDPath + "\"
    xExtArr = Array("*.xlsx*", "*.jpg", "*.pdf", "*.xlsm")
    For Each xExt In xExtArr
        xTFile = Dir(xSPath & xExt)
        Do While xTFile <> ""
            xSFile = xSPath & xTFile
            [COLOR=rgb(235, 107, 86)]FileCopy xSFile, xDPath & xTFile[/COLOR]
            Kill xSFile
            xTFile = Dir
            xCount = xCount + 1
        Loop
    'Next cell
    Next
    MsgBox "Nombre de fichier déplacés est : " & xCount, vbInformation, ""
End Sub

Si quelqu'un à une idée, je prends, j'ai tout donnée pour adapter ce code à mon fichier.. ^^' plus de jus ici.
Le fichier est en copie.

d'avance merci à tous et bonne nuit,

Dranreb · 26 Juillet 2021

Donc tous les mêmes fichiers trouvés envoyées en copies multiples dans tous ces dossiers ?

pulelian · 26 Juillet 2021

je commence à comprendre. Je cherche plutôt à ce que les fichiers originaux soient déplacés vers ces dossiers

Dranreb · 26 Juillet 2021

Alors il faut trouver une règle définissant vers quel dossier doit être envoyé chaque fichier en fonction de son nom (ou du FileDateTime du fichier ?). C'est peut être la boucle du Dir qui doit englober le choix de la destination et pas l'inverse.

pulelian · 26 Juillet 2021

Je cherche à faire :

Pour tout fichier dont l'extension est ("*.xlsx*", "*.jpg", "*.pdf", "*.xlsm") dans le dossier \Ranger (chemin fixe), alors déplace les documents selon le chemin qui lui ai correspondant (ici via récupération des données = nom des docs sur des cellules, puis grâce à des formules redécoupe le nom pour créer chaque chemin variable)

Dranreb · 26 Juillet 2021

Pas clair. Si votre colonne A est en rapport avec les noms des fichiers il faut l'intégrer dans votre Dir

pulelian · 26 Juillet 2021

ok, oui j'ai cru comprendre et modifié comme suit :

VB:

Sub MoveFiles()

'Nécessite que TOUT les dossiers mois soient crée dans chaque catégorie et sous-catégorie !!!!sinon le code ne marche pas !!

    Dim xFd As FileDialog
    Dim xTFile As String
    Dim xExtArr As Variant
    Dim xExt As Variant
    Dim xSPath As String
    Dim xDPath As String
    Dim xSFile As String
    Dim xCount As Long
    Dim doss, doss1, doss2, doss3, fich, ext, point As String
   
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
   
    NomEntreprise = "entreprisea"
    Lect = USBD
   
   
        Set Plage = Sheets("Doc_2").Range("A1:A50")
        For Each cell In Plage
            If cell <> 0 Then
    fich = cell.Value
    ext = cell.Offset(0, 1).Value
    point = cell.Offset(0, 2).Value
   
    SpecialPath = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN\Ranger"
    NomDossier = SpecialPath & "\"
     
     
    xSPath = NomDossier
    FichPath = fich '& point & ext

If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
       
           
            doss = cell.Offset(0, 3).Value
            doss1 = cell.Offset(0, 4).Value
            doss2 = cell.Offset(0, 5).Value
            doss3 = cell.Offset(0, 6).Value
           
            SpecialPath2 = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN"
            NomDossier2 = SpecialPath2 & "\" & doss & "\" & doss1 & "\" & doss2 & "\" & doss3 & "\"
           
           
            xDPath = NomDossier2
            'End If
           
           
If Right(xDPath, 1) <> "\" Then xDPath = xDPath + "\"
           
                xExtArr = Array("*.xlsx*", "*.jpg", "*.pdf", "*.xlsm")
                For Each xExt In xExtArr
                xTFile = Dir(xSPath & FichPath & xExt)
                    Do While xTFile <> ""
                    xSFile = xSPath & xTFile
                    FileCopy xSFile, xDPath & xTFile
                    Kill xSFile
                    xTFile = Dir
                    xCount = xCount + 1
                    Loop
                Next
            End If
        Next cell
    MsgBox "Nombre de fichier déplacés est : " & xCount, vbInformation, ""
End Sub

ça a vraiment fonctionné une fois, avec les 2 exemple fourni (les 2 lignes).

j'ai donc changé mes exemples par d'autre facture, et ben ..... ça me remet l'erreur 76 chemin introuvable ..
j'ai crée tout les dossiers nécessaire, en vain, je comprends pas ce que je dois regarder de plus ni comment procéder à une correction.
ça me fait péter les plombs

Dranreb · 26 Juillet 2021

Bonjour.
Mettez des espions sur xSFile et xDPath & xTFile, vous devriez y voir plus clair.

pulelian · 26 Juillet 2021

oui :

Cela me semble correcte

pulelian · 26 Juillet 2021

je pense avoir trouvé (la honte..) .. je reviens dans quelques minutes pour la réponse finale ^^

pulelian · 26 Juillet 2021

oui le code suivant fonctionne :

VB:

Sub MoveFiles()

'Nécessite que TOUT les dossiers mois soient crée dans chaque catégorie et sous-catégorie !!!!sinon le code ne marche pas !!

    Dim xFd As FileDialog
    Dim xTFile As String
    Dim xExtArr As Variant
    Dim xExt As Variant
    Dim xSPath As String
    Dim xDPath As String
    Dim xSFile As String
    Dim xCount As Long
    Dim doss, doss1, doss2, doss3, fich, ext, point As String
  
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
  
    NomEntreprise = "entreprisea"
    Lect = USBD
  
  
        Set Plage = Sheets("Doc_2").Range("A1:A50")
        For Each cell In Plage
            If cell <> 0 Then
    fich = cell.Value
    ext = cell.Offset(0, 1).Value
    point = cell.Offset(0, 2).Value
  
    SpecialPath = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN\Ranger"
    NomDossier = SpecialPath & "\"
    
    
    xSPath = NomDossier
    FichPath = fich '& point & ext

If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
      
          
            doss = cell.Offset(0, 3).Value
            doss1 = cell.Offset(0, 4).Value
            doss2 = cell.Offset(0, 5).Value
            doss3 = cell.Offset(0, 6).Value
          
            SpecialPath2 = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN"
            NomDossier2 = SpecialPath2 & "\" & doss & "\" & doss1 & "\" & doss2 & "\" & doss3 & "\"
          
          
            xDPath = NomDossier2
            'End If
          
          
If Right(xDPath, 1) <> "\" Then xDPath = xDPath + "\"
          
                xExtArr = Array("*.xlsx*", "*.jpg", "*.pdf", "*.xlsm")
                For Each xExt In xExtArr
                xTFile = Dir(xSPath & FichPath & xExt)
                    Do While xTFile <> ""
                    xSFile = xSPath & xTFile
                    FileCopy xSFile, xDPath & xTFile
                    Kill xSFile
                    xTFile = Dir
                    xCount = xCount + 1
                    Loop
                Next
            End If
        Next cell
    MsgBox "Nombre de fichier déplacés est : " & xCount, vbInformation, ""
End Sub

à raison que .. on nomme bien un dossier comme il faut, par exemple, le mois d'aout = 08 et pas 8!!!!!!!!!!!!!!!!!!!!!!!!!!...

MERCIIII beaucoup Dranreb pour ton temps! j'espère qu'il pourra être utile à d'autres

Effectuez une recherche sur Excel Downloads...

Microsoft 365 VBA_Classement automatique des documents à partir d'un répertoire fixe vers répertoire variable

pulelian

XLDnaute Nouveau

Pièces jointes

pulelian

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

pulelian

XLDnaute Nouveau

pulelian

XLDnaute Nouveau

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums