Copier les fichiers sélectionnés et les mettre dans un dossiers

mounir907

XLDnaute Nouveau
Bonjour,

J’ai un bouton de commande XL pour ouvrir tous fichiers sélectionnés (liens hypertexte).

Je voudrais que ces fichiers soient enregistrés automatiquement dans un dossier (EX : D:\SELECTED FILES).

les étapes à suivre :


- Sélectionner les liens hypertextes et cliquer sur le bouton de commande

- La macro affectée au bouton de commande doit :


a- Faire une copie de tous les fichiers qui se trouvent dans les liens hypertextes

b- Copier ces fichiers dans un dossier sur le PC (EX : D:\SELECTED FILES).

c- Après avoir copié ces fichiers dans le dossier, ce dernier s’ouvre automatiquement.

J'espère avoir été clair (voir ci-joint un exemple de fichier + macro)



Merci d'avance pour votre aide
 

Pièces jointes

  • TEST.xlsm
    17.5 KB · Affichages: 23
  • MACRO TO OPEN SELECTED LINKS .txt
    291 bytes · Affichages: 17

job75

XLDnaute Barbatruc
Bonjour mounir907,

Essayez cette macro :
Code:
Sub Copier()
Dim dossier$, h As Hyperlink, fichier$, nom$
dossier = "D:\SELECTED FILES\" 'à adapter
On Error Resume Next
For Each h In ActiveSheet.Hyperlinks
    fichier = h.Address
    If Not fichier Like "?:\*" Then fichier = ThisWorkbook.Path & "\" & fichier
    nom = Mid(fichier, InStrRev(fichier, "\") + 1)
    FileCopy fichier, dossier & nom 'copie
Next
Application.Dialogs(xlDialogOpen).Show dossier & "*"
End Sub
A+
 

job75

XLDnaute Barbatruc
Re,

Application.Dialogs n'est pas bien fameux, il vaut mieux utiliser la fonction Shell pour ouvrir le dossier :
Code:
Sub Copier()
Dim dossier$, h As Hyperlink, fichier$, nom$
dossier = "D:\SELECTED FILES\" 'à adapter
On Error Resume Next
For Each h In ActiveSheet.Hyperlinks
    fichier = h.Address
    If Not fichier Like "?:\*" Then fichier = ThisWorkbook.Path & "\" & fichier
    nom = Mid(fichier, InStrRev(fichier, "\") + 1)
    FileCopy fichier, dossier & nom 'copie
Next
Shell Environ("WINDIR") & "\explorer.exe " & dossier, vbNormalFocus
End Sub
A+
 

mounir907

XLDnaute Nouveau
Job75 merci bcp pour la macro.
Elle fonctionne très bien mais je voudrais juste que la macro copie seulement les fichiers ou les lignes sélectionnés et pas tout les fichiers.
EX: J'ai des fichiers (liens) de 1 à 12, quand je sélectionne les liens de 3 à 6 et je clique sur le bouton; je veux trouver les fichiers 3-4-5-6 et pas les 12 fichiers.
Merci d'avance
 

job75

XLDnaute Barbatruc
Bonsoir mounir907,

Une solution avec Application.FileDialog :
Code:
Sub Copier()
Dim dossier As FileDialog, h As Hyperlink, fichier$, nom$
Set dossier = Application.FileDialog(msoFileDialogFolderPicker)
If dossier.Show = False Then Exit Sub 'Annuler
On Error Resume Next
For Each h In ActiveSheet.Hyperlinks 'Selection.Hyperlinks
    fichier = h.Address
    If Not fichier Like "?:\*" Then fichier = ThisWorkbook.Path & "\" & fichier
    nom = Mid(fichier, InStrRev(fichier, "\"))
    FileCopy fichier, dossier.SelectedItems(1) & nom 'copie
Next
Shell Environ("WINDIR") & "\explorer.exe " & dossier.SelectedItems(1), vbNormalFocus
End Sub
A+
 

Discussions similaires