Copier coller racourci fichier excel vba

Sub LancerFonction()
Dim RepDestination As String, NomLien As String, CheminFichierInitial As String
'pour toi : RepDestination = "S:\a trier\" toujours SI j'ai bien compris... 
     'Ne pas oublier le \ en fin de répertoire....
RepDestination = "C:\Documents and Settings\Travail\Bureau\"
NomLien = "Nom de mon lien"
'ici j'ai pris un fichier pdf au hasard
CheminFichierInitial = "E:\Utilisateurs\Mes documents\TRAVAIL\2012\Commandes.pdf""
Création_Raccourci RepDestination, NomLien, CheminFichierInitial
End Sub

'Activer la bibliothèque "Windows Script Host Object Model" :
    'Sous VBE Outils/références (ALT+F11 depuis la feuille)
    'chercher puis cocher "Windows Script Host Object Model"
Public Function Création_Raccourci(Repertoire As String, NomLien As String, AccesFichier As String)
Dim Lien As String
Dim Raccourci As WshShortcut
Dim wShom As WshShell

Lien = Repertoire & NomLien & ".lnk"
Set wShom = New WshShell
Set Raccourci = wShom.CreateShortcut(Lien)
With Raccourci
    .Description = NomLien
    .TargetPath = AccesFichier
    .WindowStyle = 3
    .Save
End With
Set Raccourci = Nothing
Set wShom = Nothing
End Function

    FileCopy "a", "S:\a"

Option Explicit 

Dim CheminSource As String 

Private Sub CommandButton2_Click() 
'Nécessite (du moins je crois) l'activation de la référence "Microsoft Scripting Runtime" 
    'Sous VBE (ALT+F11 depuis la feuille) : Outils/références 
    'chercher puis cocher "Microsoft Scripting Runtime" 
Dim fso As FileSystemObject, Lig As Integer 
Dim Rep As Folder, SousRep As Folder 
     
    CheminSource = SelectionRep("Sélectionner le répertoire") & "\" 
    Set fso = New FileSystemObject 
    Set Rep = fso.GetFolder(CheminSource) 
     
    For Each SousRep In Rep.SubFolders 
        Lig = Lig + 1 
        Range("C" & Lig) = Split(SousRep, "\")(UBound(Split(SousRep, "\"))) 
        'En option (inutile) le chemin d'accès aux sous répertoires : 
        'Range("D" & Lig) = SousRep 
    Next 
    Columns("C:C").EntireColumn.AutoFit 
End Sub 

Function SelectionRep(Titre As String) As String 
Const ssfTous = &H1 
Dim objShell As Object, objFolder As Object, oFolderItem As Object 
    Set objShell = CreateObject("Shell.Application") 
    Set objFolder = objShell.BrowseForFolder(&H0&, Titre, ssfTous) 
    If objFolder Is Nothing Then Exit Function 
    Set oFolderItem = objFolder.Items.Item 
    SelectionRep = oFolderItem.Path 
    Set objShell = Nothing 
    Set objFolder = Nothing 
    Set oFolderItem = Nothing 
End Function

Lermitte222, me suis permis de reprendre ton classeur exemple et y ajouter le code demandé aujourd'hui.

Function SelectionRep(Titre As String, Optional Slach As Boolean) As String     
Const ssfTous = &H1     
Dim objShell As Object, objFolder As Object, oFolderItem As Object     
    Set objShell = CreateObject("Shell.Application")     
    Set objFolder = objShell.BrowseForFolder(&H0&, Titre, ssfTous)     
    If objFolder Is Nothing Then Exit Function     
    Set oFolderItem = objFolder.Items.Item     

'MODIFIER ICI     
    SelectionRep = oFolderItem.Path & IIf(Slach And Right(oFolderItem.Path, 1) _     
    <> "\", "\", "")     

    Set objShell = Nothing     
    Set objFolder = Nothing     
    Set oFolderItem = Nothing     
End Function

    CheminSource = SelectionRep("Sélectionner le répertoire", True)

'Nécessite (du moins je crois) l'activation de la référence "Microsoft Scripting Runtime" 

Sub ListerRep()
Dim fso As FileSystemObject, Lig As Integer
Dim Rep As Folder, SousRep As Folder
 Dim CheminSource As String
    'met ton chemin d'accès au répertoire désiré ici
    CheminSource = "C:\Documents and Settings\Bureau\"    
    'ou dans la cellule A1 de ta feuille :
    ' CheminSource = Range("A1").Value 'avec saisi dans A1 : "C:\Documents and Settings\Bureau\"
Set fso = New FileSystemObject
    Set Rep = fso.GetFolder(CheminSource)
     
    For Each SousRep In Rep.SubFolders
        Lig = Lig + 1
        Range("C" & Lig) = Split(SousRep, "\")(UBound(Split(SousRep, "\")))
        'En option (inutile) le chemin d'accès aux sous répertoires :
        'Range("D" & Lig) = SousRep
    Next
    Columns("C:C").EntireColumn.AutoFit
End Sub