Macro clé USB vers disque dur

  • Initiateur de la discussion Initiateur de la discussion Citaro
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Citaro

XLDnaute Occasionnel
Bonjour au forum,
Je désire copier un répertoire Gestion et ses fichiers d'une clé USB sur le disque dur C avec l'aide d'une macro, j'ai cette opération à effectuer sur plusieurs 150 pc.
J'ai une macro qui copie le fait mais seulement quand le disque dur est C et la clé F.
Je voudrais le faire même si la clé est différent de F en récupérant la lettre de la clé sur la Feuil 1 en B2.
Je n'arrive pas à modifier la ligne "f:\Gestion" & "\*", Sheets("Feuil1").Range("A2") & "Gestion" pour y arriver
Un petit coup de pouce serait le bien venu.

Merci d'avance
Citaro


Sub save().
ThisWorkbook.save
On Error Resume Next
MkDir Sheets("Feuil1").Range("A2") & "Gestion" 'crée le répertoire s'il n'existe pas
CreateObject("Scripting.FileSystemObject").CopyFile _
"f:\Gestion" & "\*", Sheets("Feuil1").Range("A2") & "Gestion"

MsgBox "Sauvegarde du répertoire Gestion effectuée avec succés !" _
& vbCrLf & " " & vbCrLf & "Emplacement: " _
& Sheets("Feuil1").Range("A2") & "Gestion", vbInformation, " Copie " & ThisWorkbook.Name
Application.DisplayAlerts = True
Application.Quit
ThisWorkbook.Close
End Sub
 
Re : Macro clé USB vers disque dur

Bonjour à tous,

Evite de nommer ta Sub par Save
Evite le Application.Quit

Peux-tu essayer:
VB:
Option Explicit

Sub Sauve()
Dim Lettre&
ThisWorkbook.Save
On Error Resume Next
MkDir Feuil1.Range("A2") & "Gestion" 'crée le répertoire s'il n'existe pas
For Lettre = 65 To 90
CreateObject("Scripting.FileSystemObject").CopyFile _
Chr(Lettre) & ":\Gestion" & "\*", Feuil1.Range("A2") & "Gestion"
Next Lettre
MsgBox "Sauvegarde du répertoire Gestion effectuée avec succés !" _
& vbCrLf & " " & vbCrLf & "Emplacement: " _
& Feuil1.Range("A2") & "Gestion", vbInformation, " Copie " & ThisWorkbook.Name
Application.DisplayAlerts = True
'Application.Quit
ThisWorkbook.Close
End Sub

A+ à tous
 
Re : Macro clé USB vers disque dur

Rebonjour,
Ce code fonctionne, est il possible d'ajouter dans cette macro la création d'un raccourci sur le bureau du répertoire Gestion que l'on vient de créer.
J'ai trouvé ce code mais il fait un raccourci d'un fichier, je ne sais pas l'adapter

Sub CreerRaccourci()
Dim raccourci As Object, bureau$, fLNK$
bureau = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
With ActiveWorkbook
'Vérifie l'existence d'un chemin pour le classeur
If .Name <> .FullName Then
fLNK = Dir$(bureau & "ONLINE*xls" & ".lnk")
If (Len(fLNK) > 0) Then
Kill bureau & fLNK
End If
With CreateObject("WScript.Shell")
Set raccourci = .CreateShortcut(bureau & ActiveWorkbook.Name & ".lnk")
End With
'Crée le raccourci sur le bureau Windows
raccourci.TargetPath = .FullName
raccourci.Save
End If
End With
End Sub

Merci d'avance
 
Re : Macro clé USB vers disque dur

Après quelques recherches ce code fonctionne:

Sub test()
Dim Shell, DesktopPath, URL
Set Shell = CreateObject("WScript.Shell")
DesktopPath = Shell.SpecialFolders("Desktop")
Set URL = Shell.createshortcut(DesktopPath & "\Ici.lnk")
CreateObject ("Scripting.FileSystemObject")
URL.TargetPath = "C:\Gestion\"
URL.Save
Set oFS = Nothing
End Sub

Bon weekend
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour