Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1576to1580
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Pfad wird nicht angelegt

Pfad wird nicht angelegt
24.08.2017 22:41:51
Stefan
Hallo liebe Gemeinde,
ich mal wieder ein weiteres Problem.
Wenn ich die Ordner manuell anlegen schreibt er mir die CSV sauber rein,
sobald ich den Ordner lösche und von EXCEL anlegen lassen will sagt er mir PFAD NICHT VORHANDEN. Was mach ich falsch ?
Sub SpeichernBestand()
Dim datei As String, Text As String
Dim Zeile As Long
Dim pfad As String
Dim name As String
Dim letztezeile As Integer
On Error GoTo Fehler
Dim Fileformat As Object
Dim oname As String
Dim vdatei As String
Dim a As String
Dim jahr As Integer
Dim monat As String
jahr = Format(Now, "YYYY")
monat = Format(Now(), "Mmmm")
oname = "IST_Bestand" & "\"
AktuellesDatum = Date
pfad = ThisWorkbook.Path & "\"
name = "IST-Bestand am "
vdatei = pfad & oname & "\" & jahr & "\" & monat & "\"
datei = vdatei & name & Date & " um " & Format(Now, "HH.MM") & " Uhr" & ".csv"
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set fs = CreateObject("Scripting.FileSystemObject")
If Dir(pfad & oname, vbDirectory) = "" Then MkDir pfad & oname
If fs.folderexists(vdatei) Then
GoTo schreiben
Else
a = MsgBox("Ordner " & vdatei & " nicht gefunden!" & vbLf & "Ordner anlegen?",  _
vbQuestion + vbYesNo, "Frage")
If a = vbYes Then MkDir (vdatei)
GoTo schreiben
schreiben:
Application.DisplayAlerts = False
Open (datei) For Output As #1 'Zieldatei öffnen
For Zeile = 1 To letztezeile
'reinschreiben
Print #1, Cells(Zeile, 1) & ";" & Cells(Zeile, 2) & ";" & Cells(Zeile, 3) & ";" & Cells(Zeile, _
_
4) & ";" & Cells(Zeile, 5) & ";" & Cells(Zeile, 6) & ";" & Cells(Zeile, 7) & ";" & Cells(Zeile, _
8) & ";" & Cells(Zeile, 9) & ";" & Cells(Zeile, 10) & ";" & Cells(Zeile, 11) & ";" & Cells( _
Zeile, 12) & ";" & Cells(Zeile, 18) & ";"
Next Zeile
Close #1    'Zieldatei schließen
Application.DisplayAlerts = True
Exit Sub
Fehler:
Close #1
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
'End If
End If
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Pfad wird nicht angelegt
25.08.2017 08:32:28
UweD
Hallo
Du musst die Ordner stufenweise anlegen.
außerdem
aus:
vdatei = pfad & oname & "\" & jahr & "\" & monat & "\"
mache:
vdatei = pfad & oname & jahr & "\" & monat & "\"
oname hat schon ein \ am Ende
Hier mal der komplette code
Sub SpeichernBestand()

Dim datei As String, Text As String
Dim Zeile As Long
Dim pfad As String
Dim Name As String
Dim letztezeile As Integer
On Error GoTo Fehler
Dim Fileformat As Object
Dim AktuellesDatum As Date
Dim oname As String
Dim vdatei As String
Dim a As String
Dim jahr As Integer
Dim monat As String
Dim FS

jahr = Format(Now, "YYYY")
monat = Format(Now(), "Mmmm")
oname = "IST_Bestand" & "\"
AktuellesDatum = Date
pfad = ThisWorkbook.Path & "\"
Name = "IST-Bestand am "
vdatei = pfad & oname & jahr & "\" & monat
datei = vdatei & Name & Date & " um " & Format(Now, "HH.MM") & " Uhr" & ".csv"
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set FS = CreateObject("Scripting.FileSystemObject")

    If Dir(pfad & oname, vbDirectory) = "" Then MkDir pfad & oname
    
    If Dir(pfad & oname & jahr, vbDirectory) = "" Then MkDir pfad & oname & jahr
    

    If FS.folderexists(vdatei) Then
            
            GoTo schreiben

            Else
            
            a = MsgBox("Ordner " & vdatei & " nicht gefunden!" & vbLf & "Ordner anlegen?", _
vbQuestion + vbYesNo, "Frage")
            
            If a = vbYes Then MkDir (vdatei)
            GoTo schreiben
        
schreiben:

Application.DisplayAlerts = False

Open (datei) For Output As #1 'Zieldatei öffnen 

 

For Zeile = 1 To letztezeile
'reinschreiben 
  Print #1, Cells(Zeile, 1) & ";" & Cells(Zeile, 2) & ";" & Cells(Zeile, 3) & ";" & Cells(Zeile, _
 _
 4) & ";" & Cells(Zeile, 5) & ";" & Cells(Zeile, 6) & ";" & Cells(Zeile, 7) & ";" & Cells(Zeile, _
 8) & ";" & Cells(Zeile, 9) & ";" & Cells(Zeile, 10) & ";" & Cells(Zeile, 11) & ";" & Cells( _
Zeile, 12) & ";" & Cells(Zeile, 18) & ";"



Next Zeile

Close #1    'Zieldatei schließen 

Application.DisplayAlerts = True

Exit Sub

Fehler:
Close #1
    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"

'End If 
End If

End Sub
LG UweD
LG UweD
Anzeige
AW: Pfad wird nicht angelegt
25.08.2017 08:48:36
Tino
Hallo,
versuch es so.
Löschen den alten Code und lege diesen in ein normales Modul.
kommt als Code in Modul1
Option Explicit 

#If Win64 Then
Public Declare PtrSafe Function apiCreateFullPath Lib "imagehlp.dll" Alias _
"MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long
#Else
Public Declare Function apiCreateFullPath Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" _
(ByVal lpPath As String) As Long
#End If

Sub SpeichernBestand()

Dim datei$, Text$, sString$, pfad$, name$, jahr$, monat$
Dim lngRet&, Zeile&, letztezeile&
Dim FS As Object
Dim a As VbMsgBoxResult
On Error GoTo Fehler

jahr = Format(Now, "YYYY")
monat = Format(Now(), "Mmmm")


pfad = ThisWorkbook.Path
pfad = pfad & IIf(Right$(pfad, 1) <> "\", "\", "")
pfad = pfad & "IST_Bestand" & "\" & jahr & "\" & monat & "\"

name = "IST-Bestand am "

datei = pfad & name & Date & " um " & Format(Now, "HH.MM") & " Uhr" & ".csv"

letztezeile = Tabelle1.Cells(Tabelle1.Rows.Count, 1).End(xlUp).Row
Set FS = CreateObject("Scripting.FileSystemObject")

If Not FS.folderexists(pfad) Then
a = MsgBox("Ordner" & vbCr & "'" & pfad & "'" & vbCr & "nicht gefunden!" _
& vbCr & vbCr & "Ordner anlegen?", vbQuestion + vbYesNo, "Frage")
If a = vbYes Then
lngRet = apiCreateFullPath(pfad)
End If
If lngRet <> 1 Then
MsgBox "Ordner konnte nicht angelegt werdnen!", vbCritical
Exit Sub
End If
End If

Open (datei) For Output As #1 'Zieldatei öffnen

With Application
For Zeile = 1 To letztezeile
'reinschreiben
sString = Join(.Transpose(.Transpose(Tabelle1.Cells(Zeile, 1).Resize(, 18))), ";")
Print #1, sString
Next Zeile
End With

Close #1 'Zieldatei schließen


Exit Sub

Fehler:
Close #1
Debug.Print datei
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub

Gruß Tino
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige