Macro générant des raccourcis de fichiers

Bonjour,
Peut être pourrais tu nous copier le code de ta macro d'origine? Avec cela nous serions à même de la modifier.

bonjour Pijaku,
excuses du retard et merci de ta suggestion
ci dessous le code en question:

Sub insère_fichiers_affaires()
'macro qui :
'à partir de l'onglet affaire effectue les opération de copie ou de création
' de répertoire pour mettre en place dans le répertoire d'affaire crée les fichiers aux endroits précisés

Dim filesysobj As Object
Dim Racine As Object
Dim ledossierNMoinsUn As Object
Dim RepSource, RepDest, FicSource, FicDest, NoDevis, NoAff, NomAffaire, Action As String
Dim R As Integer
Dim Msg, Style, Title, Response, verifaction

Set filesysobj = CreateObject("Scripting.FileSystemObject")
Set Racine = filesysobj.GetFolder(ThisWorkbook.Path)
Set ledossierNMoinsUn = Racine.ParentFolder

Sheets("Fiche").Select

verifaction = Cells(2, 3).Value ' cellule C2
If verifaction <> "" Then
Msg = "Cette opération va réinitialiser les données des fichiers déjà en place. Continuer ?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Alerte écrasement" ' Define title.

' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then ' User chose no : exit sub.
Exit Sub
End If
End If

NoDevis = Cells(12, 3).Value
NoAff = Cells(12, 2).Value
NomAffaire = Cells(8, 2).Value

Sheets("Affaire").Select
'effacer la colonne F de résultat d'éxécution de la macro
Range("F2:F1000").Select
Selection.ClearContents

' en cas d'erreur on reporte l'erreur dans la case col "F" ligne n° R
On Error GoTo TraiteErr

For R = 2 To 50

Action = Cells(R, 1).Value
' Action = UCase(Action) 'on convertit en majuscule
RepSource = Cells(R, 2).Value
FicSource = Cells(R, 3).Value
RepDest = Cells(R, 4).Value
FicDest = Cells(R, 5).Value

If Action = "COPIE" Then
Cells(R, 6).Value = "Copie OK" ' on le met avant car si pb sera écrasé
FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document)
End If
If Action = "CREREP" Then
Cells(R, 6).Value = "CreRep OK" ' on le met avant car si pb sera écrasé
MkDir Racine & "\" & RepDest
End If
If Action = "CRERAC" Then ' on copie le raccourci vers le fichier
Cells(R, 6).Value = "Raccourci OK" ' on le met avant car si pb sera écrasé
'' FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document)
End If

Next R

Sheets("Fiche").Select
Cells(2, 3).Value = "affaire copié" ' en ligne 2 colonne 3 (C2)

Exit Sub

MERCI de ton aide
Gilles 72

Alors essaye de voir dans cette piste :
remplacer :

If Action = "CRERAC" Then ' on copie le raccourci vers le fichier 
Cells(R, 6).Value = "Raccourci OK" ' on le met avant car si pb sera écrasé 
'' FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document) 
End If 

par :

Dim adresse as String
If Action = "CRERAC" Then ' on copie le raccourci vers le fichier 
Cells(R, 6).Select ' on le met avant car si pb sera écrasé 
adresse = RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=adresse 
End If 

A adapter bien entendu