Ach so...
09.11.2021 15:46:02
Yal
Hallo Uwe,
Jetzt dass ich die Worddatei schliesse, entdecke ich wo den SVerweis reinkommen soll.
Anstatt Konstante Pfad1 ein Variable Projektname verwenden. Diese mit dem VLookup von voher befüllen.
Private Function Datei_öffnen(ProjektNrEingabe As String) As Boolean
'Unter Anbindung (Extras, Verweise...) von "Microsoft Scripting Runtime"
Dim Fso As New Scripting.FileSystemObject 'Der Präfix Scripting ist nicht notwendig. Nur zur Sichtbarkeit
Dim oOrdner As Scripting.Folder
Dim oDatei As Scripting.File
Dim Dateiname As String
Dim Projektname As String
Const Pfad0 = "R:\2021_Projekte\"
Const Pfad2 = "1) Projektmanagement (Kst.500)\"
Const Pfad3 = "3) Kaufteile & Anfertigung\"
'Projektname mit SVerweis abholen
Projektname = Application.WorksheetFunction.VLookup(ProjektNrEingabe, Worksheets("Tabelle1").Range("A:B"), 2, False)
'wenn Pfad nicht vorhanden, dann Fehler, dann weitergehen
On Error Resume Next
Set oOrdner = Fso.GetFolder(Pfad0 & ProjektNrEingabe & " - " & Projektname)
'wenn Verzeichnis nicht existiert --> herstellen
If oOrdner Is Nothing Then
Fso.CreateFolder (Pfad0 & ProjektNrEingabe & " - " & Projektname & Pfad2 & Pfad3)
End If
'jetzt sollte das Verzzeichnis existieren
Set oOrdner = Fso.GetFolder(Pfad0 & ProjektNrEingabe & Pfad1 & Pfad2 & Pfad3)
'da wir jetzt nicht mehr wissen, ob Verzeichnis selber herstellt oder nicht, Datei prüfen
Dateiname = ProjektNrEingabe & " - " & Formular & ".xlsm"
Set oDatei = Fso.GetFile(oOrdner.Path & "\" & Dateiname)
If Not oDatei Is Nothing Then
MsgBox "Die Datei existiert bereits. Starte nochmals mit der ProjektNr-Eingabe"
Datei_öffnen = False 'Rückmeldung
Else
ThisWorkbook.SaveAs Filename:=Path & ProjektNrEingabe & " - " & Formular & ".xlsm"
MsgBox "Die Datei wurde umbenannt. Weiter mit der Datei" & ProjektNrEingabe & " - " & Formular & ".xlsm"
Datei_öffnen = True 'Rückmeldung
'' Call Reset
End If
'Sauberer Abgang
Set oOrdner = Nothing
Set oDatei = Nothing
End Function
Sicherer wäre mit einer Schleife auf die Unterordner von "2021_Projekte" zu gehen, so kommt es nicht zu einem Problem, falls irgendjemand sich vertippt hat:
Dafür kann man eine Function derfinieren:
Private Function SubFolder_prüfen(ProjektNr As String) As String
Dim Fso As New FileSystemObject
Dim F As Folder
Const Pfad0 = "R:\2021_Projekte\"
For Each F In Fso.GetFolder(Pfad0).SubFolders
If InStr(1, F.Name, ProjektNr) Then
SubFolder_prüfen = F.Path
Exit Function 'Beschleuniger: Wenn gefunden, den Rest sparen
End If
Next
End Function
Diese wird vor
Set oOrdner = Fso.GetFolder(Pfad0 & ProjektNrEingabe & " - " & Projektname)
verwendet. Falls ein Verzeichnis gefunden wird, kann man auch ggü die vom SVerweis zurückgegebene Wert abgleichen und meckern, Falls nicht gleich ;-)
VG
Yal