Copier des répertoire via macro excel VBA

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

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

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+

Salut à Tous....

En fait VBA c'est pas si compliqué...

Bientôt je publirai le résultat de mes recherche....

A+

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:

<gras>Erreur d'éxécution "1004"
Nom de champs introuvable ou incorrect dans la plage d'extraction</gras>

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

salut Gloups 61 ,je vous tire mon chapeau.