Option Explicit
    
Sub textdateien_uebernehmen()
Dim lngLaufZahl As Long
Dim strDateiNamen As Variant
Dim trgWB As Excel.Workbook
Dim tmpWB As Excel.Workbook
Dim trgWBName As String
Dim bslashPos As Integer
Dim shName As String
    
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
    
strDateiNamen = Application.GetOpenFilename("Text-Dateien(*.txt*),*.txt*", MultiSelect:=True)
    
If IsArray(strDateiNamen) Then
    For lngLaufZahl = LBound(strDateiNamen) To UBound(strDateiNamen)
        If lngLaufZahl = LBound(strDateiNamen) Then
            Set trgWB = Workbooks.Open(Filename:=strDateiNamen(lngLaufZahl))
            trgWB.Sheets(1).UsedRange.Columns("A").Select
            'Hier das Trennzeichen ggf. ändern und das Format der einzelnen Spalten als Array definieren
            Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=True
            For bslashPos = Len(strDateiNamen(lngLaufZahl)) To 1 Step -1
                If Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\" Then Exit For
            Next bslashPos
            shName = strDateiNamen(lngLaufZahl)
            shName = Right(shName, Len(shName) - bslashPos)
            shName = Left(shName, Len(shName) - 4)
            If Len(shName) > 31 Then shName = Left(shName, 31)
            trgWB.Sheets(1).Name = shName
            trgWB.Sheets(shName).Range("A1").Select
            trgWBName = Application.GetSaveAsFilename(, "Excel-Arbeitsmappe (*.xls),*.xls")
            trgWB.SaveAs trgWBName, xlWorkbookNormal
        Else
            Set tmpWB = Workbooks.Open(Filename:=strDateiNamen(lngLaufZahl))
            tmpWB.Sheets(1).UsedRange.Columns("A").Select
            Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=True
            For bslashPos = Len(strDateiNamen(lngLaufZahl)) To 1 Step -1
                If Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\" Then Exit For
            Next bslashPos
            shName = strDateiNamen(lngLaufZahl)
            shName = Right(shName, Len(shName) - bslashPos)
            shName = Left(shName, Len(shName) - 4)
            If Len(shName) > 31 Then shName = Left(shName, 31)
            tmpWB.Sheets(1).Name = shName
            tmpWB.Sheets(shName).Range("A1").Select
            tmpWB.Sheets(1).Copy After:=trgWB.Sheets(trgWB.Sheets.Count)
            trgWB.Save
            tmpWB.Close False
            Set tmpWB = Nothing
        End If
    Next lngLaufZahl
    
Else
    Set trgWB = Workbooks.Open(Filename:=strDateiNamen)
    trgWB.Sheets(1).UsedRange.Columns("A").Select
    Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=True
    For bslashPos = Len(strDateiNamen) To 1 Step -1
        If Mid(strDateiNamen, bslashPos, 1) = "\" Then Exit For
    Next bslashPos
    shName = strDateiNamen
    shName = Right(shName, Len(shName) - bslashPos)
    shName = Left(shName, Len(shName) - 4)
    If Len(shName) > 31 Then shName = Left(shName, 31)
    trgWB.Sheets(1).Name = shName
    trgWB.Sheets(shName).Range("A1").Select
    trgWBName = Application.GetSaveAsFilename(, "Excel-Arbeitsmappe (*.xls),*.xls")
    trgWB.SaveAs trgWBName, xlWorkbookNormal
End If
Set trgWB = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Exit Sub
Fehler:
MsgBox "Fehlernummer: " & Err.Number & Chr(10) _
& "Fehlerbeschreibung: " & Err.Description & Chr(10) _
& "Verursacht durch: " & Err.Source, vbInformation, "Fehler..."
Err.Clear
Resume Next
End Sub

Versuchs mal damit. Severus