cyberdevil0815
Goto Top

Excel 2007 Anlegen einer Bestimmten Ordnerstruktur auf verschiedene Netzlaufwerke

Anlegen von gleicher Auftragsnummer mit verschiedener Auftragsbeschreibung ist nicht möglich, ich erhalte einen VB Fehler

Hallo zusammen,

ergänzend zu meinen Ursprungsposting:

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

wurde die Anforderung erweitert bzw. im Laufenden EInsatz mittels des Excelsheets, hat sich eine Erweiterung ergeben, welche aus dem PDF Dok zu entnehmen ist.

Hier steht auch die explizite Fehlerbeschreibung drin.

http://www.project-ae/download/2011-11-21-VBA-Excel-Fehler.pdf

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



   Set WSHShell = CreateObject("WScript.Shell")  
        'Hier kommt der Verweis nach G hin  
        Set ProjektShortcut = WSHShell.CreateShortcut(ANR & "\" & "Mechanik.lnk")  
        'Wohin soll der Link verweisen  
        ProjektShortcut.TargetPath = OS10  'Mechanik  
        ProjektShortcut.Save
        Set ProjektShortcut = Nothing
        Set WSHShell = Nothing


'*******************************************************************  
'*** 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

Content-Key: 176576

Url: https://administrator.de/contentid/176576

Ausgedruckt am: 19.03.2024 um 09:03 Uhr

Mitglied: bastla
bastla 21.11.2011 um 16:37:07 Uhr
Goto Top
Hallo cyberdevil0815!

Der Link zur PDF-Datei ist unvollständig ...

... aber abgesehen davon wäre meine erste Empfehlung, mit zB
MsgBox OS10
zur Kontrolle vorweg den fraglichen Pfad einmal anzuzeigen ...

Grüße
bastla
Mitglied: cyberdevil0815
cyberdevil0815 22.11.2011 um 10:05:28 Uhr
Goto Top
Hallo bastla,

Link angepasst, sollte nun funktionieren. Danke für den Hinweis.

Bezgl. des "MsgBox 0S10", wird sich durch den Link von alleine vermutlich klären....
Mitglied: bastla
bastla 22.11.2011 um 13:07:49 Uhr
Goto Top
Hallo cyberdevil0815!
wird sich durch den Link von alleine vermutlich klären....
Du solltest das aber trotzdem selbst einbauen und ausführen, um zu sehen, welchen Pfad "OS10" eigentlich enthält ...

Grüße
bastla
Mitglied: cyberdevil0815
cyberdevil0815 22.11.2011 um 13:25:53 Uhr
Goto Top
Ok...soweit bin ich schon gekommen...0S10 verweisst auf LW i
Mitglied: bastla
bastla 22.11.2011 um 14:30:28 Uhr
Goto Top
Hallo cyberdevil0815!
0S10 verweisst auf LW i
Das ist aber noch kein Pfad ...

... und die Fehlermeldung war doch:
Pfad nicht gefunden

Grüße
bastla