Speicher-Makro aber als 1. Festplatte

Private Sub CommandButton2_Click()
Dim Fs As Object, OrdNam As Variant, Ord As Byte, Pfad As String
Dim DateiNam As String
DateiNam = ActiveWorkbook.Name
On Error Resume Next
Pfad = OrdNam(0) & "\"
ChDrive Left(OrdNam(0), 1)
For Ord = 1 To UBound(OrdNam)
ChDir Pfad
Set Fs = CreateObject("Scripting.FileSystemObject")
If Not Fs.folderexists(Pfad & OrdNam(Ord)) Then
MkDir OrdNam(Ord)
MsgBox "Der Ordner " & vbLf & vbLf & Pfad & OrdNam(Ord) & _
vbLf & vbLf & " wurde erstellt.                                  "
Else
'' MsgBox "Der Ordner " & vbLf & vbLf & Pfad & _
''         OrdNam(Ord) & vbLf & vbLf & " existiert bereits.                 "
End If
Pfad = Pfad & OrdNam(Ord) & "\"
Next Ord
Set Fs = Nothing
' Application.DisplayAlerts = False               'Sicherheitsabfrage
ActiveWorkbook.SaveAs Filename:=Pfad & DateiNam, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
'---- ab hier ICON erstellt ------------------------------------------------
Dim wsh As Object
Dim tarLink As Object
Dim tarDeskTop As String
Set wsh = CreateObject("WScript.Shell")
tarDeskTop = wsh.SpecialFolders("Desktop")
Set tarLink = wsh.CreateShortcut(tarDeskTop & _
"\" & ThisWorkbook.Name & ".lnk")
With tarLink
.Targetpath = ThisWorkbook.FullName
.Save
End With
Set wsh = Nothing
End Sub