Ordnerpfad prüfen und speichern

Option Explicit Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _ ByVal DirPath As String) As Long Private Sub angebot_speichern() ' angebot_speichern Makro ' speichert Angebot Dim Dateiname As String Dim Ordner As String Dim result As Long Dateiname = Range("N17").Value & ".xlsm" _ Ordner = Range("N16").Value If result 0 Then ActiveWorkbook.SaveAs Filename:=Ordner & "\" & Dateiname _ , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False Else MkDir Ordner ActiveWorkbook.SaveAs Filename:=Ordner & "\" & Dateiname _ , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Du kannst nicht mehrere unterordner mit einmal anlegen.
nur wenige schauen auf Deinen Rechner und sehen die Datei.
Ich möchte gerne den Fehler im Original sehen.
Ich baue keine Datei nach. Die Zeit hat schon jemand investiert.
Ein Nachbau sieht meist anders aus als das Original. Darum sollte das Original verlinkt werden.
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten anonymisieren bzw. pseudonymisieren.

Ich gebe keinen Dank für eine Rückmeldung, da ich durch solche Beiträge nicht meine Beitragszahl erhöhen muss.
Rückmeldung ist ja in der Heutigen Zeit nicht üblich und die wenigen die eine Rückmeldung geben, mögen mir das verzeihen, das kein Danke für eine Rückmeldung kommt.

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _ ByVal DirPath As String) As Long Private Sub angebot_speichern() ' angebot_speichern Makro ' speichert Angebot Dim Dateiname As String, Ordner As String, s As String Dim result As Long Dateiname = Trim(Range("N17").Value & ".xlsm") Ordner = Trim(Range("N16").Value) If Right(Ordner, 1) "\" Then 'wichtig für 'MakeSureDirectoryPathExists' 'sonst wird das letzte Sub-Directory nicht erzeugt Ordner = Ordner & "\" End If If Dir(Left(Ordner, 3) & "*.", vbDirectory) = "" Then MsgBox "Das Laufwerk '" & UCase(Left(Ordner, 1)) & "* existiert nicht!", vbSystemModal + _ 16 Exit Sub End If If Dir(Ordner, vbDirectory) = "" Then 'statt MkDir MakeSureDirectoryPathExists Ordner While Dir(Ordner, vbDirectory) = "" 'warten, bis Ordner erstzellt wurde DoEvents Wend End If ActiveWorkbook.SaveAs Filename:=Ordner & Dateiname, _ FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False End Sub

Hallo rischu,
Mach es so:


Private Sub angebot_speichern()
' angebot_speichern Makro
' speichert Angebot
Dim Dateiname As String, Ordner As String, s As String, datTyp As String
Dim result As Long, i As Integer
Dateiname = Trim(Range("N17").Value & ".xlsm")
Ordner = Trim(Range("N16").Value)
If Right(Ordner, 1)  "\" Then
'wichtig für 'MakeSureDirectoryPathExists'
'sonst wird das letzte Sub-Directory nicht erzeugt
Ordner = Ordner & "\"
End If
If Dir(Left(Ordner, 3) & "*.", vbDirectory) = "" Then
'prüfen, ob das vorgeschlagene Laufwerk existiert
'z.B.: Y:\
MsgBox "Das Laufwerk '" & UCase(Left(Ordner, 1)) & "* existiert nicht!", _
vbSystemModal + 16
Exit Sub
End If
If Dir(Ordner, vbDirectory) = "" Then
'statt MkDir
'vorgeschlagenen Ornder anlegen (einschließlich aller Unterordner)
MakeSureDirectoryPathExists Ordner
While Dir(Ordner, vbDirectory) = ""
'warten, bis Ordner vom Betriebssystem erstzellt wurde
'dieser Prozeß hat aber eine niedrige Priorität
DoEvents
Wend
End If
'voller Dateiname einschließlich Pfad
s = Ordner & Dateiname
'Position letzter Punkt im Dateinamen
i = InStrRev(s, ".", -1, vbTextCompare)
'Dateityp vom vollen Dateinamen abhängen
s = Left(s, i - 1)
'Dateityp merken
datTyp = Mid(s, i)
For i = 2 To 200
'_2, _3,_4 usw. an den eigentlichen Dateinamen (ohne Dateityp)
'anhängen
If Dir(s & "_" & i & datTyp, vbNormal) = "" Then
'wenn es den neu gebildeten Dateinamen nicht gibt, dann raus aus der For-Schleife
Exit For
End If
Next i
'jetzt speichern mit neuem Dateinamen
ActiveWorkbook.SaveAs Filename:=s & "_" & i & datTyp, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub

Gruß von Luschi
aus klein-Paris

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread