Daten aus Excel in xml File schreiben

Private Sub saveXML()
Const Zeile1 = 1
Const SpalteEnd = 300
Dim fs, a, z, s, b
Set fs = CreateObject("Scripting.FileSystemObject")
'neues File
neu: a = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Text Files (*.xml), *. _
xml")
If a  False Then
On Error Resume Next
'altes File
alt: Set a = fs.CreateTextFile(a, False)
If Err.Number  0 Then
On Error GoTo 0
If MsgBox("Die Datei ist schon vorhanden. Soll Sie überschrieben werden?", vbYesNo, " _
Datei überschreiben?") = vbYes Then
' löschen des alten Files
Kill a
GoTo alt
Else
GoTo neu
End If
End If
On Error GoTo 0
' reinschreiben ins txt File
With Sheets("Tabelle3")
z = Zeile1
While Not IsEmpty(.Cells(z, 1))
For s = 1 To SpalteEnd
b = .Cells(z, s)
While Len(b) > 0
a.writeline (Left(b, 300))
b = Mid(b, 300)
Wend
Next s
z = z + 1
Wend
a.Close
Worksheets("Tabelle3").Cells.Clear
End With
End If
End Sub