Excel 2007 Wie kann ich Verknüpfungen mittels VBA an bestimmte Stellen über mehrere Netzlaufwerke anlegen und verteilen?

Sub Main()

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 2
Dim strData1 As String
Dim strData2 As String
Dim strData3 As String
Dim strData4 As String
Dim objWord As Object


Pfad = "G:\Projekte\"  
Pfad1 = "I:\Projekte\"  

If IsError(Sheets("Tabelle1").Cells(6, "E")) Then  
    MsgBox "Die Navisionlizenz lässt keine weiteren Anwender zu." & vbCrLf & _  
     "" & vbCrLf & _  
     "Warten Sie, bis ein anderer Anwender das Programm verlassen hat.", 48 + 0, _  
     "Projekt konnte nicht angelegt werden!"  
     Unload UserForm1
     GoTo Abbruch2
End If

A = Sheets("Tabelle1").Cells(6, "E")    'Verk. An Name  
Be = Sheets("Tabelle1").Cells(8, "E")   'Anlagennummer  
C = Sheets("Tabelle1").Cells(10, "E")   'Kom. Beschreibung  
D = Sheets("Tabelle1").Cells(12, "E")   'Nr. (Auftragsnummer)  


'*******************************************************************  
'*** Für die Ordnerstruktur ungültige Zeichen werden umgewandelt ***  
'*******************************************************************  

C = Replace(C, "/", "_")  
C = Replace(C, "\", "_")  
C = Replace(C, ":", ";")  
C = Replace(C, "*", "+")  
C = Replace(C, "<", " ")  
C = Replace(C, ">", " ")  
C = Replace(C, "|", "_")  
C = Replace(C, "?", " ")  
C = Replace(C, "Chr(34)", "Chr(39)")  

A = Replace(A, "/", "_")  
A = Replace(A, "\", "_")  
A = Replace(A, ":", ";")  
A = Replace(A, "*", "+")  
A = Replace(A, "<", " ")  
A = Replace(A, ">", " ")  
A = Replace(A, "|", "_")  
A = Replace(A, "?", " ")  
A = Replace(A, "Chr(34)", "Chr(39)")  


'*******************************************************************  
'*** Die aus Navision übernommenen Daten werden konntrolliert ******  
'*******************************************************************  


'Hat die Auftragsnummer das richtige Format?  
If IsNumeric(D) = False Then
    MsgBox "Die Auftragsnummer darf nur aus Zahlen bestehen!", 48 + 0, "Ungültige Eingabe!"  
    Unload UserForm1
    GoTo Abbruch
End If

If Len(D) <> 8 Then
    MsgBox "Die Auftragsnummer muss aus genau 8 Zahlen bestehen! Es sind aber " & Len(D), 48 + 0, "Ungültige Eingabe!"  
    Unload UserForm1
    GoTo Abbruch
End If

'Ist die Auftragsnummer vergeben?  
If D = "" Then  
    MsgBox "Es wurde kein Projekt gefunden!" & vbCrLf & _  
     "Dies kann folgende Ursachen haben:" & vbCrLf & _  
     "" & vbCrLf & _  
     "1. Die Auftragsnummer wurde falsch eingegeben." & vbCrLf & _  
     "2. Es wurde ein falscher Mandant ausgewählt.", 48 + 0, "Es wurde kein Projekt gefunden!"  
     Unload UserForm1
     GoTo Abbruch
End If

'Ist die Anlagennummer vergeben?  
If Be = "" Then  
    MsgBox "Es wurde in Navision keine Anlagennummer angegeben." & vbCrLf & _  
     "" & vbCrLf & _  
     "Bitte tragen sie diese zuerst nach, bevor sie das Projekt anlegen.", 48 + 0, _  
     "Keine Anlagennummer vergeben!"  
     Unload UserForm1
     GoTo Ende
End If

'Ist die Kom. Beschreibung vergeben?  
If C = "" Then  
    MsgBox "Es wurde in Navision keine Beschreibung angegeben." & vbCrLf & _  
     "" & vbCrLf & _  
     "Bitte tragen sie diese zuerst nach, bevor sie das Projekt anlegen.", 48 + 0, _  
     "Keine Beschreibung vorhanden!"  
     Unload UserForm1
     GoTo Ende
End If

'Ist die Anlagennummer vergeben?  
If A = "" Then  
    MsgBox "In Navision wurde das Feld 'Verk. an Name' ausgefüllt." & vbCrLf & _  
     "" & vbCrLf & _  
     "Bitte füllen sie dieses zuerst aus, bevor sie das Projekt anlegen.", _  
     48 + 0, "Keine Kundenname vorhanden!"  
     Unload UserForm1
     GoTo Ende
End If

'Anlagennummer ohne Punkt  
B = Right$(Be, 6)

'Wurde ein Ordnertyp ausgewählt?  
If Sheets("Tabelle1").Cells(3, "F") = 1 Then  
    MsgBox "Es wurde kein Ordnertyp ausgewählt", 48 + 0, "Achtung!"  
    Sheets("Tabelle1").Cells(3, "F") = ""  
    Unload UserForm1
    GoTo Abbruch
End If

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1

'*******************************************************************  
'*** Anlegen der Ordnerstruktur in Windows *************************  
'*******************************************************************  

'Erstellen des Kundenordners auf LW I  
Name = Pfad1 & A
If Dir(Name & "\", vbDirectory) = "" Then MkDir Name  

'Erstellen des Unterordners mit Anlagennummer_Beschreibung  
ANR = Pfad1 & A & "\" & B & "_" & C  
If Dir(ANR & "\", vbDirectory) = "" And Dir(Name & "\" & B & "*", vbDirectory) = "" Then  
    MkDir ANR
End If

'Erstellen der Unterordnerstruktur  
Unterordner = Pfad1 & A & "\" & B & "_" & C & "\"  

OS10 = Unterordner & "Mechanik"  
MkDir OS10




'Erstellen des Kundenordners auf LW G  
Name = Pfad & A
If Dir(Name & "\", vbDirectory) = "" Then MkDir Name  

'Erstellen des Unterordners mit Anlagennummer_Beschreibung  
ANR = Pfad & A & "\" & B & "_" & C  
If Dir(ANR & "\", vbDirectory) = "" And Dir(Name & "\" & B & "*", vbDirectory) = "" Then  
    MkDir ANR
Else:
    Ord = Name & "\" & Dir(Name & "\" & B & "*", vbDirectory)  
    ASV = Ord & "\" & "Schriftverkehr" & "\" & D & "_" & C  
    If Dir(ASV, vbDirectory) = "" Then  
        MkDir ASV
        MkDir Ord & "\" & "\" & "Doku" & "\" & "Deutsch" & "\" & "Funktionspläne" & "\" & D & "_" & C & "\"  
        MkDir Ord & "\" & "\" & "Doku" & "\" & "Deutsch" & "\" & "Datenblätter" & "\" & D & "_" & C & "\"  
        UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 7
        Unload UserForm1
        GoTo Ende
    
    Else: MsgBox "Projekt bereits vorhanden"  
          Unload UserForm1
          GoTo Abbruch
    End If
End If

'Erstellen der Unterordnerstruktur  
Unterordner = Pfad & A & "\" & B & "_" & C & "\"  

OS1 = Unterordner & "Medien"  
MkDir OS1
MkDir OS1 & "\" & "Videos"  
MkDir OS1 & "\" & "Fotos"  

OS2 = Unterordner & "Berechnung"  
MkDir OS2

OS3 = Unterordner & "Doku"  
MkDir OS3
MkDir OS3 & "\" & "Deutsch"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Bedienungsanleitung"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Funktionspläne"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Funktionspläne" & "\" & D & "_" & C  
MkDir OS3 & "\" & "Deutsch" & "\" & "Datenblätter"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Datenblätter" & "\" & D & "_" & C  
MkDir OS3 & "\" & "Englisch"  

OS4 = Unterordner & "Durchlaufplan"  
MkDir OS4

OS5 = Unterordner & "Elektro"  
MkDir OS5
MkDir OS5 & "\" & "Antriebe"  
MkDir OS5 & "\" & "Bustest"  
MkDir OS5 & "\" & "Display"  
MkDir OS5 & "\" & "E-Pläne"  
MkDir OS5 & "\" & "Sicherheitstechnik"  
MkDir OS5 & "\" & "Technische_Infos"  
MkDir OS5 & "\" & "Zubehör_Parameter"  
MkDir OS5 & "\" & "Programm"  
MkDir OS5 & "\" & "Programm" & "\" & "_Vorbereitet"  
MkDir OS5 & "\" & "Programm" & "\" & "_Vorlage"  

OS6 = Unterordner & "LLV"  
MkDir OS6

OS7 = Unterordner & "Schriftverkehr"  
MkDir OS7
MkDir OS7 & "\" & D & "_" & C  
MkDir OS7 & "\" & D & "_" & C & "\" & "Intern"  
MkDir OS7 & "\" & D & "_" & C & "\" & "Kunde"  
MkDir OS7 & "\" & D & "_" & C & "\" & "Zulieferer"  

OS8 = Unterordner & "Kalkulation"  
MkDir OS8

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1



'*******************************************************************  
'*** Exceldokumente für Ordner Kalkulation kopieren*****************  
'*******************************************************************  

'Excelsheet mitlaufende Kalkulation.xlsx speichern  

Dim objExcel As Object
Set objExcel = CreateObject("Excel.Application")  


objExcel.Application.Workbooks.Open "G:\Vordrucke\Projekte\Kalkulation\mitlaufende_Kalkulation.xlsx"  

 With objExcel.ActiveWorkbook
        .SaveAs Filename:=Unterordner & "Kalkulation\mitlaufende_Kalkulation" & "_" & D & ".xlsx"  
        .Close
    End With


Set objExcel = Nothing


'Daten aus Exceldatei einlesen  
strData1 = A
strData2 = B
strData3 = C
strData4 = D

'Excelsheet Nachkalkulation_geschlossen.xlsx speichern  

Set objExcel = CreateObject("Excel.Application")  


objExcel.Application.Workbooks.Open "G:\Vordrucke\Projekte\Kalkulation\Nachkalkulation_geschlossen.xlsx"  

 With objExcel.ActiveWorkbook
        .SaveAs Filename:=Unterordner & "Kalkulation\Nachkalkulation_geschlossen" & "_" & D & ".xlsx"  
        .Close
    End With


Set objExcel = Nothing


'Daten aus Exceldatei einlesen  
strData1 = A
strData2 = B
strData3 = C
strData4 = D


'*******************************************************************  
'*** Die Worddokumente werden bearbeitet****************************  
'*******************************************************************  


'Kopieren des Inhaltsverzeichnisses  
FileCopy "G:\Vordrucke\VD_Inhaltsverzeichnis Projektordner.doc", Unterordner & "Inhaltsverzeichnis.doc"  

'Daten in Projektstand.xls eintragen  

Set objExcel = CreateObject("Excel.Application")  


objExcel.Application.Workbooks.Open "G:\Vordrucke\Projektstand.xls"  
objExcel.Application.Sheets("Tabelle1").Select  

 With objExcel.ActiveWorkbook
        .Sheets("Tabelle1").Cells(1, "B") = A  
        .Sheets("Tabelle1").Cells(5, "B") = D  
        .Sheets("Tabelle1").Cells(6, "B") = B  
        .Sheets("Tabelle1").Cells(7, "B") = C  
        .SaveAs Filename:=Unterordner & "Projektstand" & "_" & D & ".xlsx"  
        .Close
    End With


Set objExcel = Nothing


'Daten aus Exceldatei einlesen  
strData1 = A
strData2 = B
strData3 = C
strData4 = D


'*** Daten in "Vordruck für Ordnerrücken.doc" einfügen ***  
If Sheets("Tabelle1").Cells(2, "F") = 1 Then  
    Set objWord = CreateObject("Word.Application")  
    
   '*** Hier wird der Pfad der Wordvorlage angegeben ***  
    objWord.documents.Open "G:\Vordrucke\VD_Vordruck für Ordnerrücken_v1.doc"  
    
    'Text in die Textmarken einfügen  
    With objWord
        .ActiveDocument.Bookmarks("Firma").Range.Text = strData1  
        .ActiveDocument.Bookmarks("Beschreibung").Range.Text = strData3  
        .ActiveDocument.Bookmarks("Anlagennummer").Range.Text = strData2  
    End With
    
    'Dokument speichern unter  
    objWord.ActiveDocument.SaveAs Unterordner & "Vordruck für Ordnerrücken.doc"  

    'word beenden  
    objWord.Quit
    
    'objekt löschen  
    Set objWord = Nothing

End If

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1

If Sheets("Tabelle1").Cells(1, "F") = 1 Then  
    Set objWord = CreateObject("Word.Application")  
    

    '*** Hier wird der Pfad der Wordvorlage angegeben ***  
    objWord.documents.Open "G:\Vordrucke\VD_Vordruck für Ordnerrücken_schmal_v1.doc"  
    
    With objWord
        .ActiveDocument.Bookmarks("Firma").Range.Text = strData1  
        .ActiveDocument.Bookmarks("Beschreibung").Range.Text = strData3  
        .ActiveDocument.Bookmarks("Anlagennummer").Range.Text = strData2  
    End With
    
'Dokument speichern unter  
objWord.ActiveDocument.SaveAs Unterordner & "Vordruck für Ordnerrücken_schmal.doc"  

'Word beenden  
objWord.Quit
    
'objekt löschen  
Set objWord = Nothing
End If

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 2
    
'Daten in "VD_Änderungen während des laufenden Projektes_v1.doc" einfügen  
Set objWord = CreateObject("Word.Application")  



'*** Hier wird der Pfad der Wordvorlage angegeben ***  
objWord.documents.Open "G:\Vordrucke\VD_Änderungen während des laufenden Projektes_v1.doc"  
    
With objWord
    
    .ActiveDocument.Bookmarks("Firma").Range.Text = strData1  
    .ActiveDocument.Bookmarks("Beschreibung").Range.Text = strData3  
    .ActiveDocument.Bookmarks("Anlagennummer").Range.Text = strData2  
    .ActiveDocument.Bookmarks("Kommissionsnummer").Range.Text = strData4  
    End With
    

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 2

'Dokument speichern unter  
objWord.ActiveDocument.SaveAs Unterordner & "Änderungen während des laufenden Projektes"  

'word beenden  
objWord.Quit

'objekt löschen  
Set objWord = Nothing

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1

Unload UserForm1

Ende:
MsgBox "Projekt wurde erfolgreich erstellt"  

Abbruch2:
Application.DisplayAlerts = False
Workbooks("Projektordner.xls").Close SaveChanges:=False  

Abbruch:
Unload UserForm1
Unload Projektdokumentation
Application.WindowState = xlMaximized

End Sub