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
.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
.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
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
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