Warum, Leute, könnt ihr nie richtig beschreiben was Ihr wirklich wollt? Fast jedesmal muß man Code nachbessern oder komplett umarbeiten, weil ihr Euer Problem falsch oder unvollständig beschreibt! Das verursacht unnötige Arbeits und vor allem Ärger: Schließlich habe ich anderes zu tun als x-mal Code anzupassen, weil Ihr Eure Probleme nicht so darlegt wie sie wirklich sind! Bitte in Zukunft wirklich so beschreiben, wie Ihr die Lösung wirklich haben wollt!

Option Explicit
      
Sub textdateien_uebernehmen()
Dim strZielDatei As String
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
'Ereignisse abschalten
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
      
'Zieldatei auswählen und öffnen
strZielDatei = Application.GetOpenFilename("Excel-Arbeitsmappe (*.xls),*.xls", , "Zieldatei auswählen...", , False)
Set trgWB = Workbooks.Open(strZielDatei)

'Zu importierende Textdateien auswählen
strDateiNamen = Application.GetOpenFilename("Text-Dateien(*.txt*),*.txt*", , "Zu importierende Textdateien auswählen...", , True)
      
'Mehrere Dateien ausgewählt
If IsArray(strDateiNamen) Then
    For lngLaufZahl = LBound(strDateiNamen) To UBound(strDateiNamen)
            Set tmpWB = Workbooks.Open(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
            'In Zieldatei kopieren
            tmpWB.Sheets(1).Copy After:=trgWB.Sheets(trgWB.Sheets.Count)
            trgWB.Save
            'Temporäre Datei ohne speichern schließen, Verweis freigeben
            tmpWB.Close False
            Set tmpWB = Nothing
    Next lngLaufZahl
'Nur eine Datei ausgwählt
Else
    Set tmpWB = Workbooks.Open(strDateiNamen)
    tmpWB.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(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
'Verweis freigeben
Set trgWB = Nothing
'Ereignisse einschalten
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

Severus