Prueba esto,
Sub CrearAccesoDirecto()
NumError = CreateShortCut("C:\MiArchivo.xls", "Desktop")
End Sub
Function CreateShortCut(FileName As String, Destination As Variant, Optional Args As String) As Long
Dim WScript As Object
Dim WShortCut As Object
Dim ShortCutPath As String
On Error GoTo CreateShortCut_Error
If Len(Dir(FileName)) = 0 Then Err.Raise 52
Set WScript = CreateObject("WScript.Shell")
ShortCutPath = WScript.SpecialFolders(Destination)
If Len(ShortCutPath) = 0 Then
ShortCutPath = Destination
If Len(Dir(ShortCutPath, vbDirectory)) = 0 Then
Err.Raise 52
End If
End If
Set WShortCut = WScript.CreateShortCut(ShortCutPath & "\" & Dir(FileName) & ".lnk")
WShortCut.TargetPath = FileName
' Aqui puedes indicar el icono
WShortCut.IconLocation = FileName & ", 0"
WShortCut.WorkingDirectory = Left(FileName, Len(FileName) - Len(Dir(FileName)))
' indicas los argumentos
WShortCut.Arguments = Args
WShortCut.Save
CreateShortCut = -1
Exit_CreateShortCut:
Set WShortCut = Nothing
Set WScript = Nothing
On Error GoTo 0
Exit Function
CreateShortCut_Error:
CreateShortCut = Err.Number
Resume Exit_CreateShortCut
End Function