selection, recherche et copie dans des repertoires et sous repertoires

[pouloucarine]

Bonsoir à tous,

j'aurai besoin d'améliorer la macro jointe.

En effet, je souhaite pouvoir choisir mon répertoire (et tous les sous répertoires en dessous) et pouvoir choisir (et/ou) crééer mon répertoire de destination.

Actuellement ces éléments sont en durs dans la macro.

Pourriez vous m'aider à optimiser cette macro.

Merci d'avance

Cordialement

pouloucarine

 

[Iznogood1]

Re : selection, recherche et copie dans des repertoires et sous repertoires

Pour choisir un répertoire

Sub ChoixRep()
  Dim m_Dialog As FileDialog
  Set m_Dialog = Application.FileDialog(msoFileDialogFolderPicker)
  If m_Dialog.Show <> 0 Then MsgBox "Répertoire sélectionné : " & m_Dialog.SelectedItems(1)
End Sub

 

[pouloucarine]

Re : selection, recherche et copie dans des repertoires et sous repertoires

Bonjour,

merci pour cette réponse (que je garde en mémoire pour un autre traitement), mais j'ai essayé de l'intégrer dans mon code et j'ai un doute sur le fait que celà réponde à mon souci.

Ici le code mis à jour

Sub dupliean()

Dim P As Range, DosSource$, DosDestin$, ext$, c As Range, DernLigne As Long
DernLigne = Range("A" & Rows.Count).End(xlUp).Row
Set P = Range("A1:A" & DernLigne) 'plage avec les noms des fichiers (sans extension)
DosSource = FileDialog
Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If FileDialog.Show <> 0 Then MsgBox "Répertoire sélectionné : " & FileDialog.SelectedItems(1) 'à adapter
DosDestin = "C:\Test\" 'à adapter
ext = ".jpg"
Application.DisplayAlerts = False
On Error Resume Next
MkDir DosDestin 'crée le dossier s'il n'existe pas
For Each c In P
FileCopy DosSource & c & ext, DosDestin & c & ext
c(1, 2) = IIf(Dir(DosDestin & c & ext) = "", "", "OK")
Next
MsgBox Application.CountA(P.Offset(, 1)) & " fichiers copiés"
End Sub

J'ai bien la boite de dialogue pour sélectionner un répertoire, j'ai bien l'info que le répertoire est sélectionné mais j'ai un doute sur les sous-répertoires.

Est-ce qu'il manque quelquechose à mon code ?

Merci

pouloucarine

 

[pouloucarine]

Re : selection, recherche et copie dans des repertoires et sous repertoires

J'ajoute que celà peut être des répertoires avec tous ses sous-répertoires, mais aussi un lecteur et du coup tous ses répertoires/sous répertoires

Merci

pouloucarine

 

[Iznogood1]

Re : selection, recherche et copie dans des repertoires et sous repertoires

Sub Demo()
  Const RepDest = "C:\temp"
  Const ext = ".jpg"
  
  Dim m_Dialog As FileDialog
  Dim r As Range
  
  If Dir(RepDest, vbDirectory) = "" Then MkDir (RepDest)
  
  Set m_Dialog = Application.FileDialog(msoFileDialogFolderPicker)
  If m_Dialog.Show <> 0 Then
    For Each r In Range("A1:A" & Range("A1").CurrentRegion.Rows.Count)
      MsgBox m_Dialog.SelectedItems(1) & "\" & r.Value & ext
    Next r
  End If
End Sub

Bien sûr modifie les valeurs des 2 constantes RepDest et ext selon ton besoin

 

[pouloucarine]

Re : selection, recherche et copie dans des repertoires et sous repertoires

Bonjour,

merci pour ce code mais je dois définitivement être blond.

Le code me crée bien le répertoire de destination
Il va bien "explorer" le répertoire sélectionné
Il m'indique bien qu'il cherche un fichier du type A1.jpg
Mais par contre une fois trouvé, il ne me le copie pas vers mon rep de destination et je dois faire ok à chaque "item" trouvé.

En gros, je n'arrive pas à intégrer ce code dans ma macro de copie du fichier une fois celui-ci trouvé.

Pouvez vous m'indiquer comment mettre celà en forme ?

Cordialement

pouloucarine

 

[pouloucarine]

Re : selection, recherche et copie dans des repertoires et sous repertoires

Bonjour,

je n'y arrive toujours pas :

ma macro suivante fonctionne très bien :

Sub dupliean()

Dim P As Range, DosSource$, DosDestin$, ext$, c As Range, DernLigne As Long
DernLigne = Range("A" & Rows.Count).End(xlUp).Row
Set P = Range("A1:A" & DernLigne) 'plage avec les noms des fichiers (sans extension)
DosSource = "Z:\" 'à adapter
DosDestin = "D:\Test\" 'à adapter
ext = ".jpg"
Application.DisplayAlerts = False
On Error Resume Next
MkDir DosDestin 'crée le dossier s'il n'existe pas
For Each c In P
FileCopy DosSource & c & ext, DosDestin & c & ext
c(1, 2) = IIf(Dir(DosDestin & c & ext) = "", "", "OK")
Next
MsgBox Application.CountA(P.Offset(, 1)) & " fichiers copiés"
End Sub

Je souhaiterai pouvoir simplement changer le DosSource, c'est à dire que je puisse sélectionner un répertoire avec une fenêtre explorer windows et que celà puisse recherche dans le répertoire et tous les sous-répertoires de répertoire, voir un lettre lecteur réseau.

Tout le reste est ok

Merci de votre aide

Pouloucarine