Copier des répertoire via macro excel VBA Résolu/Fermé

Question

Bonjour à tous,

j'utilise un petit programme en langage Macro Excel 4 sous Excel 2003, avec lequel j'arrive à me débrouiller!

Il me génère une liste d'arborescence de répertoire sur une feuille Excel du type:

   c:/devi2008/AA080555/
   c:/devi2008/AA080412/
   c:/devi2008/AA080412/
   c:/devi2007/AA070183/
etc..

Je souhaiterai à partir de cette liste :
  - supprimer les doublons de la liste
  - copier chaque  répertoire contenu dans chacune des cellules de la liste
    sur une autre unité logique (l'arborescence étant définit dans une cellule d'une autre colonne)
  - La copie se faisant sans message de contrôle de l'existance des répertoires de destination
  - éventuellement un message de fin "copie effectuer" + valid "OK"

Tout cela c'est si simple avec la souris dans l'explorateur, l'automatiser est une autre affaire

J'ai jeter un oeil dans différent forum, mais VBA, me dépasse complètement.

Merci si quelqu'un peut m'aider dans ma quète..

Gloups61 · Accepted Answer

Salut ...

Comme je vous disait précédament, je peux enfin publier le résultat de mon codage
qui fonctionne...

Code :

Sub Sauve()

' Appel de la procédure de sélection du répertoire destination de la copie
RepSave

   If Range("P2") = "" Then MsgBox "Procédure de copie annulée"
   If Range("P2") = "" Then GoTo Fin

' Procédure de tri de la liste avant extraction des doublons
TriOrdre

' Procédure d'extraction des doublons
ListeUnique

   If Range("L2") = "" Then MsgBox "Pas de dossiers à sauvegarder !"
   If Range("L2") = "" Then GoTo Fin

' procédure de copie des répertoires à sauvegarder
PrepaCopyRep
   MsgBox "Copies effectuées"
              
' repositionnement sur la feuille de calcul
Fin:
Range("A2").Select

End Sub
__________________________________

Sub RepSave()

Dim objFSO1
Static Message As String
Dim RepSauve As String
Dim ZoneTxt As Range


'Worksheets("Pinstal2b").Select
RepSauve = Range("P1")
           
' Gestion FSO pour Copie des répertoires et fichiers
Set objFSO1 = CreateObject("Scripting.FileSystemObject")

'Sélection du répertoire destination de la copie
    Message = InputBox("Répertoire de destination :", "Sauvegarde Devis", _
    RepSauve)
        
        'Enregistrement du répertoire de sauvegarde
        If Message = "" Then
            Range("P2").Value = Message
        Else: Range("P2").Value = "ok"
        End If
        
        If Message = "" Then Exit Sub
        Range("P1").Value = Message
        RepSauve = Message
       
    'création répertoire de sauvegarde
    If Not objFSO1.FolderExists(RepSauve) Then
    objFSO1.CreateFolder (RepSauve)
    End If
    
Range("A2").Select

End Sub
_______________________________

Sub TriOrdre()

'ajout d'un titre à la listre
Range("J1") = "A_titre"

' Tri par ordre alphabétique de la liste, facilite l'extraction sans doublon...
    Columns("J:J").Select
        Selection.Sort Key1:=Range("J1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub
___________________________________

Sub ListeUnique()

'Utilisation d'un Filtre avancé pour obtenir
'l'unicité de chaque répertoire à copier
' les colonnes I:I et K:K doivent rester vides
    Range("J1:J1000").Select
    Range("J1:J1000").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Columns("L:L"), Unique:=True
    
Range("A2").Select

End Sub
___________________________________

Sub PrepaCopyRep()

'Procedure permetant la copie des répertoires disponibles dans la liste (L:L)
' La copie se fait de C: vers P:
' dans mon cas P: est une unité logique affectée à un répertoire sur un serveur

Debut:

Dim objFSO
Dim RepSrc As String    'C:\devi2008\Devi0899\AA089900
Dim RepDst As String    'P:\_save\devi2008\Devi0899\AA089900
Dim RepDevAn As String  'P:\_save\Devi2008\Devi0899
Dim RepAn As String     'P:\_save\Devi2008
Dim RepSauve As String  'P:\_save
Dim FinListe As Range
Dim Cpt As Integer

'affichage de message dans la barre d'information d'excel
Range("P3") = Application.DisplayStatusBar
Application.DisplayStatusBar = True

' boucle pour la copie de tous les répertoire de la liste (L:L)
'début de boucle
Cpt = 0
Do

    'Chargement des répertoires devis
    RepSrc = Range("L2")
    RepSauve = Range("P1")

    'Décomposition des répertoires à créer
    RepDst = Replace(RepSrc, Left(RepSrc, 2), (RepSauve))
    Range("M1") = RepDst

    RepDevAn = Replace(RepDst, Right(RepDst, 9), "")
    Range("N1") = RepDevAn

    RepAn = Replace(RepDevAn, Right(RepDevAn, 9), "")
    Range("O1") = RepAn

    Application.StatusBar = "Copie en cours ...  " & RepDst
              
    'Copie des répertoires et fichiers
    Set objFSO = CreateObject("Scripting.FileSystemObject")

        'création répertoire Année
        If Not objFSO.FolderExists(RepAn) Then
        objFSO.CreateFolder (RepAn)
        End If

        'création répertoire DeviAnNo (Devi0899)
        If Not objFSO.FolderExists(RepDevAn) Then
        objFSO.CreateFolder (RepDevAn)
        End If
    
        'création répertoire du Devis (AA089900)
        If Not objFSO.FolderExists(RepDst) Then
        objFSO.CreateFolder (RepDst)
        End If

        If objFSO.FolderExists(RepSrc) Then
        objFSO.CopyFolder RepSrc, RepDst, True
        End If

    'Supression de la ligne du répertoire copié
    Range("L2").Select
    Selection.Delete Shift:=xlUp
    
'test de boucle
Set FinListe = Range("L2")
Loop While FinListe.Offset(Cpt) <> ""

'Nettoyage en fin de copie
Columns("I:K").Clear
Range("A2").Select
Application.StatusBar = "Prêt"
Application.StatusBar = False
Application.DisplayStatusBar = Range("P3").Value


End Sub

J'espère simplement que mon travail permetra à quelques débutants de trouver le courage
de se lancer dans la programmation en VB, car il m'a fallut que quelques soirées
pour établir ce code, grace aux forums et un peu de persévérance...

Il y a un mois, je ne connaissait rien au VB...

Je remercie tous ceux qui n'ont pas voulu répondre à mes messages et m'ont ainsi permis
de découvrir ce langage...

Au revoir

Gloups61 · Answer

Salut à tous,

Ouhais mon message n'est pas trop clair,
en fait je souhaite créé une macro excel en Vba, me permettant d'effectuer 
les copies comme décrit ci dessus

As mes temps perdu j'essai de retrouver des ptit bout de programmes me permettant
d'arriver a faire ce dont j'ai besoin, mais VBA c'est tout de même pas si simple...

Merci à ceux qui voudront bien ammener leur coopération à mon ptit soucis..

A+

Gloups61 · Answer

Salut à Tous....

En fait VBA c'est pas si compliqué...

Bientôt je publirai le résultat de mes recherche....

A+

Gloups61 · Answer

Salut... J'ai largement avancé sur mon projet, mais la je coince sur un "Bug" J'ai une procédure (récupérée via l'enregistreur de Macro) qui fonctionne bien certaine fois, mais d'autre ou apparait le message suivant: Erreur d'éxécution "1004" Nom de champs introuvable ou incorrect dans la plage d'extraction Voici le morceau de code en VBA: Range("J1:J2").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Columns("K:K"), Unique:=True Si quelqu'un peut m'aider , merci d'avance

Gloups61 · Answer

Salut ...

Super le filtre avancé avec extraction sans doublon mais pour qu'il fonctionne bien
il faut que les colonnes précédentes et suivantes de celles que l'on trie soient VIDE !
C'est une des caractéristique des fonctions liées aux listes .

Code: 

' extraction sans doublon 
Range("J1:J2").AdvancedFilter Action:=xlFilterCopy, _ 
CopyToRange:=Columns("L:L"), Unique:=True 

fonctionne bien si les colonnes I & K sont vides

ALG16 · Answer

salut Gloups 61 ,je vous tire mon chapeau.

Copier des répertoire via macro excel VBA

6 réponses

Discussions similaires