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,

Compte Supprimé 979 · 26 Juillet 2021

Bonjour Pulelian,

C'est quoi ce lecteur dans votre code

VB:

Lect = USBD

Ca ne peut être qu'une lettre, celle de votre clé USB, si c'est bien ce que vous voulez faire

@+

pulelian · 26 Juillet 2021

Bonjour BrunoM45,

Lect = USB est défini via une fonction plus loin dans le module :

'Lect = USBD
Function USBD()
Set fs = CreateObject("Scripting.FileSystemObject")
Tmp = ""
For Each d In fs.Drives
If d.DriveType = 1 Then
If d.IsReady Then Tmp = Tmp & d.DriveLetter
End If
Next
USBD = Tmp
End Function

Je travaille sur clé, avec 2 ordinateurs et à termes je devrais filer mon projet donc j'ai placé ceci afin d’arrêter d'avoir le message d'erreur "le chemin est erroné.." pour mes autres codes.

Du coup cette fonction marche bien ailleurs (pour enregistrer le fichier, pour inscrire sur fichier txt ce que j'ai fais = log, pour mettre à jour des données vers autre classeur).

Ici le message d'erreur bloque sur :

FileCopy xSFile, xDPath & xTFile

et si je défini comme suit :

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

pas de message, le code s’exécute (au moins) mais il va me ranger les documents au même endroits...

alors que si je défini comme suit :

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

j'ai le message d'erreur 76.

J'espère que j'ai pu t'éclairer plus, merciii à toi ^^

Dranreb · 26 Juillet 2021

Bonjour.
Si les sous dossiers doivent être créés s'il n'existent pas il faut des instructions MkDir avant de pouvoir y mettre des fichiers.

pulelian · 26 Juillet 2021

Bonjour Dranreb,

Les dossiers 2018 et 2019 existaient déjà. J'ai, dans le doute, crée aussi les dossiers faisant référence aux mois (de 1 à 12) et ai joué le code cependant toujours cette fameuse erreur :

merci pour ta réponse quand même ^^

Dranreb · 26 Juillet 2021

Il faut croire que non, il ne sont pas créés si ça entraine une erreur 76: chemin introuvable
Mais vous pouvez les créer si nécessaires avec des instructions MkDir

pulelian · 26 Juillet 2021

Dranreb re,

J'ai crée les dossiers mensuels aussi dans B. CONTRAT, le code s'est enfin exécuté d'où l'explication de l'erreur 2, mercii ! cela me débloque pas mal!

Pour mon exemple, les 2 docs :

2019-10-10_FRS_A. FACTURE_AMAZON_num_Apple airpods avec boitier de charge	pdf		B. FOURNISSEUR	A. FACTURE	2019	10
2018-11-21_FRS_A. FACTURE_AMAZON_num_Kitchenaid accessoire machine à pâte pour robot	pdf		B. FOURNISSEUR	B. CONTRAT	2018	11

se sont rangés dans B. FOURNISSEUR\B. CONTRAT\2018\11

Pourtant je pensais qu'avec :

VB:

    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

il n'y aurait pas de doute quant à la direction du fichier, une idée encore ?

merci beaucoup,

Dranreb · 26 Juillet 2021

Rétablissez le Next Cell tout à la fin, enlevez les Next sans rien, et corrigez correctement ce qui vous avait conduit à faire ça.

pulelian · 26 Juillet 2021

J'ai rétabli le Next cell (celui commenté tout en bas), puis erreur sur l'utilisation du Next.
Donc j'ai fait cela :

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 = "SolidSnack"
    Lect = USBD
    SpecialPath = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN\Ranger"
    NomDossier = SpecialPath & "\"
    
      
    Dim doss, doss1, doss2, doss3 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
            
            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 & xExt)
                Do While xTFile <> ""
                xSFile = xSPath & xTFile
                FileCopy xSFile, xDPath & xTFile
                Kill xSFile
                xTFile = Dir
                xCount = xCount + 1
                Loop
            Next
        Next cell
    MsgBox "Nombre de fichier déplacés est : " & xCount, vbInformation, ""
End Sub

Maintenant tout s'est bien rangé ... dans les dossiers de la première ligne uniquement

Désolé pour cette incompétence.. j'essaie decomprendre..
Une nouvelle suggestion ?

merciii

Dranreb · 26 Juillet 2021

Il me semble que le End If devrait être juste avant le Next Cell.

pulelian · 26 Juillet 2021

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
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    
    NomEntreprise = "SolidSnack"
    Lect = USBD
    SpecialPath = Lect & ":\clé usb\DOSSIERS\" & NomEntreprise & "\A. FINANCE ET ADMIN\Ranger"
    NomDossier = SpecialPath & "\"
    
      
    Dim doss, doss1, doss2, doss3 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
            
            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 & 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

Malheureusement cela tombe toujours dans le dossier de la première ligne uniquement..

why?. je continue à chercher

Dranreb · 26 Juillet 2021

En fait je ne comprends rien à ce que vous voulez faire.
Pouvez vous me l'expliquer ?
Sont-ce les mêmes fichiers que vous voulez transférer à différents endroits ?
Ou sinon qu'est-ce qui doit aller respectivement où ?

pulelian · 26 Juillet 2021

et bien pour le document dont les infos sont les suivantes (ligne 1) :

2019-10-10_FRS_A. FACTURE_AMAZON_num_Apple airpods avec boitier de charge

pdf

B. FOURNISSEUR

A. FACTURE

2019

10

le classer dans le dossier B.FOURNISSEUR\A. FACTURE\2019\10
et pour le document dont les infos sont les suivantes (ligne2 ) :

2018-11-21_FRS_A. FACTURE_AMAZON_num_Kitchenaid accessoire machine à pâte pour robot

pdf

B. FOURNISSEUR

B. CONTRAT

2018

11

le classer dans le dossier B.FOURNISSEUR\B. CONTRAT\2018\11

soit 2 dossiers différents.

Dranreb · 26 Juillet 2021

Oui mais classer quoi ?
Ce n'est pas la destination qui n'est absolument pas clair, c'est la source !

pulelian · 26 Juillet 2021

les documents (fichier) dont les extension peuvent être ("*.xlsx*", "*.jpg", "*.pdf", "*.xlsm")

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

Compte Supprimé 979

Guest

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

pulelian

XLDnaute Nouveau

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums