TXT Import Spalten trennen geht nicht

Sub ImportiereTXTDateien()

Const TXTPFAD = "U:\Txt"

Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet, f As  _
Object, i As Integer, fso As New FileSystemObject

Set fso = CreateObject("Scripting.Filesystemobject")

Set wbTarget = ActiveWorkbook

Application.DisplayAlerts = False

'Lösche alle Worksheets bevor wir alle neu anlegen

While wbTarget.Worksheets.Count > 1

wbTarget.Worksheets(1).Delete

Wend

wbTarget.Worksheets(1).Name = ("Daten")

wbTarget.Worksheets(1).Range("A:ZZ").Clear

For Each f In fso.GetFolder(TXTPFAD).Files

If LCase(Right(f.Name, 3)) = "txt" Then

Workbooks.OpenText Filename:=f.Path

Set wbSource = ActiveWorkbook

On Error Resume Next

Set ws = wbTarget.Worksheets(f.Name)

If Err  0 Then

Set ws = wbTarget.Worksheets.Add

ws.Name = f.Name

ws.Range("A:ZZ").Clear

End If

wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=ws.Range("A1"),  _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=False, Comma:=True, TrailingMinusNumbers:=True, TabDelimiter:=True, SpaceDelimiter:=False, TrailingMinusNumbers:=True, DecimalSeparator:=",", ThousandsSeperator:="."

wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")

wbSource.Close True

End If

Next

Set fso=Nothing
End Sub