XL 2016 Création de dossiers à partir d'une Base de Données

  • Initiateur de la discussion Initiateur de la discussion APPRENTI:)
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

APPRENTI:)

XLDnaute Nouveau
Tout à bord, merci à vous pour votre aide souvent précieuse !!!

Habituellement, j'arrive à obtenir ce que je souhaite avec des formules Excel. Mais pour ce dernier, je pense qu'il faut passer en VBA, et pour le coup, je n'y connais rien !
Je vous explique mon souhait :

J'ai créé une base de donnée qui renseigne des détails sur des clients.

Il y a 6 désignations différentes dans la Base de Données : CHANTIER, GROUPE, FOURNISSEUR, ENTREPRISE, ARCHITECTE, PARTICULIER qui correspondent à 6 Dossiers Types présents sur le bureau.
Puis une colonne nom.

Sur le bureau, en plus des 6 dossiers Types, il y a 6 dossiers pour recueillir les nouveaux dossiers.

L'idée est par exemple, lorsque j'ajoute un nom X avec la désignation CHANTIER dans la base de données, le dossier CHANTIER TYPE qui se trouve sur le bureau soit copié et renommé X puis placé dans le dossier CHANTIER.

Idem, si j'ajoute un nom Y avec la désignation FOURNISSEUR dans la base de données, le dossier FOURNISSEUR TYPE qui se trouve sur le bureau soit copié et renommé Y puis placé dans le dossier FOURNISSEUR.

Et cela pour les 6 désignations différentes.

J'ai créé un dossier avec les différents dossiers et fichiers, comment puis je vous l'envoyer ?

Merci a vous, et bon confinement !!
 

Pièces jointes

Solution
Avec ce dossier (3) et cette macro les dossiers TYPE sont copiés et A B C... créés une seule fois :
VB:
Sub Renommer_Transferer()
Dim fso As Object, chemin$, tablo, i&, dossier1$, dossier2$, dossier3
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path & "\"
tablo = Feuil1.UsedRange.Resize(, 3)
For i = 3 To UBound(tablo)
    If tablo(i, 1) <> "" And tablo(i, 3) <> "" Then
        dossier1 = chemin & UCase(tablo(i, 1))
        dossier2 = dossier1 & " TYPE"
        dossier3 = dossier1 & "\" & tablo(i, 3)
        If Dir(dossier1, vbDirectory) = "" Then MkDir dossier1 'crée le dossier s'il n'existe pas
        If Dir(dossier2, vbDirectory) = "" Then MkDir dossier2 'crée le dossier s'il n'existe pas
        If...
Ok job75 milles excuses
j'ai testé ceci devrait suffire
VB:
Sub test2()
    Dim OFSO, dossierAcopier$, Dossdestination$, nom$
    Set OFSO = CreateObject("Scripting.FileSystemObject")
    Base = ThisWorkbook.Path
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        dossierAcopier = Base & "\" & UCase(Cells(i, "A")) & " TYPE"
        Dossdestination = Base & "\" & UCase(Cells(i, "A"))
        If Dir(Base & "\" & UCase(Cells(i, "A")), vbDirectory) = "" Then MkDir Base & "\" & UCase(Cells(i, "A"))
        nom = "pour " & Cells(i, "C")
        If Dir(Dossdestination & "\" & nom, vbDirectory) = "" Then
            OFSO.CopyFolder dossierAcopier, Dossdestination & "\" & nom, True   'copie du dossier dans son nouveau parent
        End If
    Next
End Sub

sensiblement la même chose
 
Avec ce dossier (3) et cette macro les dossiers TYPE sont copiés et A B C... créés une seule fois :
VB:
Sub Renommer_Transferer()
Dim fso As Object, chemin$, tablo, i&, dossier1$, dossier2$, dossier3
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path & "\"
tablo = Feuil1.UsedRange.Resize(, 3)
For i = 3 To UBound(tablo)
    If tablo(i, 1) <> "" And tablo(i, 3) <> "" Then
        dossier1 = chemin & UCase(tablo(i, 1))
        dossier2 = dossier1 & " TYPE"
        dossier3 = dossier1 & "\" & tablo(i, 3)
        If Dir(dossier1, vbDirectory) = "" Then MkDir dossier1 'crée le dossier s'il n'existe pas
        If Dir(dossier2, vbDirectory) = "" Then MkDir dossier2 'crée le dossier s'il n'existe pas
        If Dir(dossier3, vbDirectory) = "" Then fso.copyfolder dossier2, dossier3 'copie et crée le dossier une seule fois
    End If
Next
End Sub
Une fois créés la macro ne touche plus aux dossiers A B C etc.
 

Pièces jointes

Avec ce dossier (3) et cette macro les dossiers TYPE sont copiés et A B C... créés une seule fois :
VB:
Sub Renommer_Transferer()
Dim fso As Object, chemin$, tablo, i&, dossier1$, dossier2$, dossier3
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path & "\"
tablo = Feuil1.UsedRange.Resize(, 3)
For i = 3 To UBound(tablo)
    If tablo(i, 1) <> "" And tablo(i, 3) <> "" Then
        dossier1 = chemin & UCase(tablo(i, 1))
        dossier2 = dossier1 & " TYPE"
        dossier3 = dossier1 & "\" & tablo(i, 3)
        If Dir(dossier1, vbDirectory) = "" Then MkDir dossier1 'crée le dossier s'il n'existe pas
        If Dir(dossier2, vbDirectory) = "" Then MkDir dossier2 'crée le dossier s'il n'existe pas
        If Dir(dossier3, vbDirectory) = "" Then fso.copyfolder dossier2, dossier3 'copie et crée le dossier une seule fois
    End If
Next
End Sub
Une fois créés la macro ne touche plus aux dossiers A B C etc.

Merci!!!! vous êtes des Pros!!

juste pour que je comprenne, à quoi correspond les dossiers 1, 2, 3?
 
Quelle efficacité!!

j'ai une dernière question.

Une fois les projets terminés, un bilan va être réalisé et je pense qu'il sera plus lisible de basculer la ligne vers l'onglet bilans répertoriant les bilans de tous les projets terminés.

Ce qui serait génial, c'est que le dossier du projet soit également déplacé dans un dossier BILAN répertoriant tous les projets terminés.

est-ce qu'il faut passer aussi par une macro qui ferait les 2 opérations en même temps?

Est ce que cela fait l'objet d'un autre sujet?

merci beaucoup à vous de faire partager votre savoir!!!
 
Bonjour Job 75,

Ton code fonctionne très bien!!
j'ai essayé de décaler la colonne "Nom", mais apparemment ça pose un problème.
Que dois-je changer au code pour pouvoir placer la colonne nom à coté de la colonne désignation?

Très bon Week-end à tous!
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
5
Affichages
562
Réponses
9
Affichages
827
Retour