Hallo,

ich habe folgendes Makro um mehrer txt-Dateien in eine Excel-Tabelle einzufügen. Zudem wird der Dateiname, in dem zusätzliche Daten enthalten sind, in die erste Spalte kopiert. Der Code dazu sieht so aus:

Sub TastIt()
Dim Wsh As Worksheet
Dim dateien, x, r, c
    
   dateien = Application.GetOpenFilename _
      ("txt-Dateien (*.txt), *.txt", MultiSelect:=True)
   If IsArray(dateien) Then
      Application.ScreenUpdating = False
      Set Wsh = ThisWorkbook.ActiveSheet
         Wsh.Cells.Clear
         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
         On Error GoTo 0
TheEnd:
      If ActiveWorkbook.Name <> ThisWorkbook.Name Then ActiveWorkbook.Close False
      Set Wsh = Nothing
      Application.ScreenUpdating = True
   End If
 
End Sub



Es ist so, dass die Daten in dem Dateinamen durch Unterschriche getrennt sind (nach TIME sogar 2 Unterstriche). So z.B.
1071489_SN_0385763KBL3D_Gramm_5°C_40grad_7ml_Time__20_11_2018_14_23_49.txt 
Wie kann ich in dem Makro einfügen, dass die einzelnen Daten in jeweils eine eigene Spalte eingetragen werden?