http://www.vba-forum.de/Forum/View.aspx?ziel=48253-Mehrer_TXT-Dateien_in_Excel_einlesen

Hättest gleich schreiben können, jetzt hattu eben einen Flicken druff

Option Explicit

Sub TustIt()
Dim Wsh As Worksheet
Dim dateien, x, r, c, z
Dim arrS() As String, arrN() As Variant
Dim tmp As String

   dateien = Application.GetOpenFilename _
      ("txt-Dateien (*.txt), *.txt", MultiSelect:=True)
   If IsArray(dateien) Then
      Application.ScreenUpdating = False
      Set Wsh = ThisWorkbook.ActiveSheet
         Wsh.Cells.Clear
         Wsh.Columns.UseStandardWidth = True
         On Error GoTo TheEnd
         Workbooks.Open dateien(1), local:=True
         With ActiveSheet
            'Wsh.Cells(1).Value = .Parent.Name
            .UsedRange.Copy Wsh.Cells(2)
            Range(Wsh.Cells(3, 2), Wsh.Cells(3, 2).End(xlDown)).Offset(, -1).Value = .Parent.Name
            .Parent.Close False
         End With
         For x = 2 To UBound(dateien)
            With Wsh
               r = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row + 1
               c = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Column
               Workbooks.Open dateien(x), local:=True
               With ActiveSheet
                  'Wsh.Cells(r, 1).Value = .Parent.Name
                  .UsedRange.Offset(2).Copy Wsh.Cells(r, 2)
                  Range(Wsh.Cells(r, c), Wsh.Cells(r, c).End(xlDown)).Offset(, 1 - c).Value = .Parent.Name
                  .Parent.Close False
               End With
            End With
         Next x
         'Spalte A split
         With Wsh
            r = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row + 1
            c = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Column
            arrN = Range(.Cells(1, 1), .Cells(r, 1)).Value
            z = 1
            For x = 3 To r
               tmp = Replace(.Cells(x, 1).Value, "__", "_")
               arrS = Split(tmp, "_")
               If UBound(arrS) > z Then z = UBound(arrS)
            Next x
            '
            .Cells(1).Resize(, z).EntireColumn.Insert
            For x = 3 To r
               tmp = Replace(arrN(x, 1), "__", "_")
               arrS = Split(tmp, "_")
               .Cells(x, 1).Resize(, z).Value = arrS 'Application.Transpose(arrS)
            Next x
            Range(.Columns(1), Columns(z + 1)).AutoFit
         End With
         On Error GoTo 0
TheEnd:
      If ActiveWorkbook.Name <> ThisWorkbook.Name Then ActiveWorkbook.Close False
      Set Wsh = Nothing
      Application.ScreenUpdating = True
   End If

End Sub