Hilfe!!!! komm nicht mehr weiter

Sub SpeichernBestand()
Application.DisplayAlerts = False
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
jahr = Year(CDate(ThisWorkbook.Worksheets("Bestand").Range("A1")))
oname = "IST_Bestand"
AktuellesDatum = Date
pfad = ThisWorkbook.Path
name = "IST-Bestand am "
vdatei = pfad & "\" & oname & "\" & jahr
datei = vdatei & "\" & name & Date & ".csv"
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set fs = CreateObject("Scripting.FileSystemObject")
MkDir pfad & "\" & oname
If fs.folderexists(vdatei) Then
GoTo schreiben
Else
a = MsgBox("Ordner " & pfad & "\" & oname & "\" & jahr & " nicht gefunden!" & vbLf & _
_
"Ordner anlegen?", vbQuestion + vbYesNo, "Frage")
If a = vbYes Then
MkDir (vdatei)
GoTo schreiben
schreiben:
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
Exit Sub
Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End If
End If
Application.DisplayAlerts = True
End Sub