Macro clé USB vers disque dur

[Citaro]

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

 

[JCGL]

Re : Macro clé USB vers disque dur

Bonjour à tous,

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

Peux-tu essayer:

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

 

[Citaro]

Re : Macro clé USB vers disque dur

Merci JCGL et Staple1600
Ce code fonctionne comme il faut

Bon weekend à tous les 2
Citaro

 

[Citaro]

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

 

[Citaro]

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