Copier des répertoire via macro excel VBA

Résolu/Fermé

Gloups61 Messages postés 15 Date d'inscription lundi 25 décembre 2000 Statut Membre Dernière intervention 6 juillet 2009 - 23 sept. 2008 à 21:42
ALG16 Messages postés 149 Date d'inscription mardi 11 octobre 2005 Statut Membre Dernière intervention 9 novembre 2018 - 25 janv. 2009 à 21:03

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..

A voir également:

Copier des répertoire via macro excel VBA
Liste déroulante excel - Guide
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Formule excel - Guide
Copier une vidéo youtube - Guide
Macro word - Guide

6 réponses

Réponse 1 / 6

Gloups61 Messages postés 15 Date d'inscription lundi 25 décembre 2000 Statut Membre Dernière intervention 6 juillet 2009 5
21 oct. 2008 à 21:43

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

Réponse 2 / 6

Gloups61 Messages postés 15 Date d'inscription lundi 25 décembre 2000 Statut Membre Dernière intervention 6 juillet 2009 5
21 oct. 2008 à 21:09

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

Réponse 3 / 6

Gloups61 Messages postés 15 Date d'inscription lundi 25 décembre 2000 Statut Membre Dernière intervention 6 juillet 2009 5
26 sept. 2008 à 20:27

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+

Réponse 4 / 6

Gloups61 Messages postés 15 Date d'inscription lundi 25 décembre 2000 Statut Membre Dernière intervention 6 juillet 2009 5
2 oct. 2008 à 22:52

Salut à Tous....

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

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

A+

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 6

Gloups61 Messages postés 15 Date d'inscription lundi 25 décembre 2000 Statut Membre Dernière intervention 6 juillet 2009 5
7 oct. 2008 à 23:20

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

Réponse 6 / 6

ALG16 Messages postés 149 Date d'inscription mardi 11 octobre 2005 Statut Membre Dernière intervention 9 novembre 2018 3
25 janv. 2009 à 21:03

salut Gloups 61 ,je vous tire mon chapeau.

Discussions similaires

Dessiner avec son clavier et avec des lettres

recopier une formule sans décalage

Discussions similaires

Newsletters