Hallo liebe Excel-Experten,
mit untenstehendem Code erzeuge ich bei Bedarf ein neues Verzeichnis auf dem Server und versuche dann, dorthin die Datei zu speichern, die diesen Code enthält. Das klappt aber leider immer erst im 2. Anlauf ( also wenn das Verzeichnis schon vorhanden gewesen ist ).
Ich würde mich über brauchbare 
Hinweise sehr freuen.
Grüße aus Oldenburg
Thomas
Option Explicit
Dim Datei As String
Dim Angebot 'muss für LEN Variant sein!
Dim KundenName As String
Dim Ziffer As Integer
Dim OrdnerName As String
Dim Pfad As String
Dim SuchPfad As String
Dim Spalte As Integer
Dim Zeile As Integer
Public Const AV As String = „\server\daten$\ANGEBOTE\Angebotsverzeichnis.xls“
Sub Daten_holen()
Application.DisplayAlerts = False ’ Meldungen und Rückfragen unterdrücken
Application.EnableEvents = False
Datei = ActiveWorkbook.Name 'Name der aufrufenden Datei
’ bei abweichender AngebotsNummer: DatenZeile löschen
If Worksheets(„DATEN“).Cells(6, 1) Worksheets(„DATEN“).Cells(4, 3) Then Worksheets(„DATEN“).Rows(4).ClearContents
'VARIABLENWERTE BESTIMMEN
Angebot = Worksheets(„Daten“).Cells(6, 1) 'eingetragener Wert aus aufrufender Datei
Ziffer = Left(Angebot, 1)
If Len(Angebot) = 5 Then Ziffer = Left(Angebot, 2)
SuchPfad = „\server\daten$\Angebote“ & Ziffer & „“ & Angebot & „*“
'ANGEBOTSVERZEICHNIS ÖFFNEN, ZEILE SUCHEN
Workbooks.Open Filename:=AV 'AngebotsVerzeichnis öffnen
Worksheets(„alle“).Columns(3).Select
On Error GoTo Hell 'Fehlermeldung bei erfolgloser Suche abfangen
Selection.Find(What:=Angebot, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Zeile = ActiveCell.Row
On Error GoTo 0 ’ Fehlerbehandlung ausschalten
If KundenName = „“ Then KundenName = Left(Worksheets(„alle“).Cells(ActiveCell.Row, 5), 15)
OrdnerName = Dir(SuchPfad, 16) 'vbNormal = 0 (Voreinstellung) Dateien ohne Attribute.
Pfad = „\server\daten$\Angebote“ & Ziffer & „“ & OrdnerName & „“ 'realer Pfad des AngebotsOrdners am Server
'EINTRÄGE UND HYPERLINKS IN ANGEBOTSVERZEICHNIS SCHREIBEN
Cells(ActiveCell.Row, 23) = Pfad & „Projekt_“ & Angebot & „.xls“ 'TextEintrag in AngebotsVerzeichnis, Spalte 23
Cells(ActiveCell.Row, 23).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Pfad & „Projekt_“ & Angebot & „.xls“ 'Hyperlink in AngebotsVerzeichnis, Spalte 23
Cells(ActiveCell.Row, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Pfad 'Hyperlink in AngebotsVerzeichnis, Spalte 23
'EINTRÄGE UND HYPERLINKS IN AUFRUFENDE DATEI SCHREIBEN
Windows(Datei).Activate
Cells(4, 23) = Pfad & „Projekt_“ & Angebot & „.xls“ 'TextEintrag in AngebotsVerzeichnis, Spalte 23
Cells(4, 23).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Pfad & „Projekt_“ & Angebot & „.xls“ 'Hyperlink in aufrufende Datei, Zeile 4, Spalte 23
Cells(4, 3) = Angebot
Cells(4, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Pfad 'Hyperlink in aufrufende Datei, Zeile 4, Spalte 3
If KundenName = „“ Then KundenName = Left(Cells(4, 5), 15)
OrdnerName = Dir(SuchPfad, 16) 'vbNormal = 0 (Voreinstellung) Dateien ohne Attribute.
If OrdnerName = „“ Then Ordner_anlegen 'Gegebenenfalls ORDNER ANLEGEN
Pfad = „\server\daten$\Angebote“ & Ziffer & „“ & OrdnerName & „“ 'realer Pfad des AngebotsOrdners am Server
'FALLS SCHON EINE PROJEKT****.xls EXISTIERT --> DIESE ÖFFNEN
If Datei „Projekt_“ & Angebot & „.xls“ Then ’ … nur wenn die aufrufende Datei nicht besagte Projektdatei ist
If Dir(Pfad & „Projekt_“ & Angebot & „.xls“) „“ Then
MsgBox („Es existiert bereits eine Projekt.xls zu dieser AngebotsNummer. Diese wird jetzt geöffnet und der DatenImport abgebrochen.“)
Workbooks.Open Filename:=Pfad & „Projekt_“ & Angebot & „.xls“
Windows(Datei).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close 'ab hier wird der Code nicht mehr ausgeführt
'Datei = Pfad & „Projekt_“ & Angebot & „.xls“
End If
End If
Windows(„Angebotsverzeichnis.xls“).Activate
Rows(„6:8“).Select 'ÜberschriftZeilen
Application.CutCopyMode = False
Selection.Copy
Windows(Datei).Activate
Cells(1, 1).Select ’ … in die 1. Zeile der aufrufenden Datei
ActiveSheet.Paste
Windows(Datei).Activate
Worksheets(„DATEN“).Activate ’ Aufrufende Datei aktivieren
For Spalte = 1 To 26
’ leere Zellen der aufr. Datei füllen
If Worksheets(„DATEN“).Cells(4, Spalte) = „“ Then _
Worksheets(„DATEN“).Cells(4, Spalte) = Workbooks(„Angebotsverzeichnis.xls“).Worksheets(„alle“).Cells(Zeile, Spalte)
’ leere Zellen des AV füllen
If Workbooks(„Angebotsverzeichnis.xls“).Worksheets(„alle“).Cells(Zeile, Spalte) = „“ Then _
Workbooks(„Angebotsverzeichnis.xls“).Worksheets(„alle“).Cells(Zeile, Spalte) = Worksheets(„DATEN“).Cells(4, Spalte)
Next Spalte
’ AV SPEICHERN UND SCHLIESSEN
Windows(„Angebotsverzeichnis.xls“).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
’ AUFRUFENDE DATEI AKTIVIEREN
Windows(Datei).Activate
ActiveWorkbook.Save
’ AUFRUFENDE DATEI unter neuem Namen speichern
ActiveWorkbook.SaveAs Filename:=Pfad & „Projekt_“ & Angebot & „.xls“, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
’ AUFRUFENDE DATEI unter ALTEM Namen speichern
ActiveWorkbook.SaveAs Filename:="\server\daten$\VORLAGEN\Excel\Projekt.xltm", FileFormat _
:=xlOpenXMLTemplateMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False 'für LaufZeit diese Zeile auskommentieren
Worksheets(„Daten“).Cells(6, 1).Select
Application.DisplayAlerts = True ’ Meldungen und Rückfragen
Application.EnableEvents = True
Exit Sub
Hell:
MsgBox „keinen Eintrag gefunden“
Windows(„Angebotsverzeichnis.xls“).Close
Worksheets(„Daten“).Cells(6, 1).Select
Application.DisplayAlerts = True ’ Meldungen und Rückfragen
Application.EnableEvents = True
End Sub
Sub Ordner_anlegen()
If KundenName = „“ Then KundenName = InputBox(prompt:=„Geben Sie bitte einen KundenNamen ein:“, _
Title:=„Ereignisprozedur zu Open“)
OrdnerName = Angebot & „_“ & KundenName
MkDir ("\server\daten$\Angebote" & Ziffer & „“ & OrdnerName)
End Sub
