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
Combobox macro excel
