Hi,

< Das ist im Prinzip alles...

net ganz, denn ohne Musteraufbau der Einspieltabellen musste schon weiter raten

< Kann man damit etwas anfangen???

die Daten holen – vgl. Testmodul

Beste Grüße

'**************************************************************************
Rem Testmodul
Rem zur Laufzeit werden alle "alten" Einspielungen gelöscht
Rem zum Test nur von 1 - 2
Rem .QueryTables.Add - alle Standardparameter entfernt
Rem Call DoFormatTxtImport - Formatierungen der Textimporte zusammengefasst
'**************************************************************************
Option Explicit
Sub Import_Messdaten()
Const myShName As String = "Tabelle1"
Const vonNr As Integer = 1
Const bisNr As Integer = 2
Dim mySh As Worksheet
Dim x As Long
Rem zur Laufzeit werden alle "alten" Einspielungen gelöscht
  For Each mySh In ActiveWorkbook.Sheets
    If mySh.Name <> myShName Then
    Application.DisplayAlerts = Not Application.DisplayAlerts
    mySh.Delete
    Application.DisplayAlerts = Not Application.DisplayAlerts
    End If
  Next mySh
Rem Fehlerbehandlung
  For x = vonNr To bisNr
    If Not csvImport_Messdaten(x) Then GoTo errorhandler
    If Not txtImport_1(x) Then GoTo errorhandler
    If Not txtImport_2(x) Then GoTo errorhandler
    'Range("U3").Select 'es fehlen die ActiveSheet.Shapes.AddChart
  Next x
Exit Sub
errorhandler:
MsgBox "Der Lauf wurde wegen Fehler beendet"
End Sub

Sub DoFormatTxtImport(myRange)
Dim myRng As Range
Set myRng = myRange
Dim x As Long, y As Long
On Error GoTo errorhandler
  Range(myRng.Offset(4, 1), myRng.Offset(13, 5)).Cut _
    Destination:=myRng.Offset(4, 0)
  myRng.Offset(3, 0).Formula = "Stage"
  myRng.Offset(3, 1).Formula = "Time"
  myRng.Offset(3, 2).Formula = "phi_1"
  myRng.Offset(3, 3).Formula = "phi_2"
  myRng.Offset(3, 4).Formula = "Weg"
  Range(myRng.Offset(1, 0), myRng.Offset(2, 4)).ClearContents
  
  With Range(myRng, myRng.Offset(0, 4))
    .ClearContents
    .HorizontalAlignment = xlCenter
    .Font.Size = 12
    .Font.Bold = True
    .Merge
    .Interior.Color = 65535
  End With
  
  x = myRng.Column
  Range(Columns(x + 5), Columns(x + 7)).Delete Shift:=xlToLeft
  Range(Columns(x), Columns(x + 4)).ColumnWidth = 10
  With Columns(x + 5)
    .ColumnWidth = 2
    .Interior.Color = 49407
  End With
  
  Range(myRng.Offset(3, 1), myRng.Offset(100, 4)).NumberFormat = "##0.00000"
  
Exit Sub
errorhandler:
MsgBox "Fehler bei Formatierung Tabelle " & myRange.Address
End Sub

Function txtImport_2(ByVal nFile As Integer) As Boolean
Const csvDir As String = "Z:\Streifenziehanlage\Versuche 21.01.2014\Aramis-Daten\SCHNITT-STREIFEN_"
Const csvCon As String = "TEXT;"
Dim csvPath As String
Dim myCell As Range
On Error GoTo NoQuerry

  csvPath = csvCon & csvDir & Format(nFile, "000") & "_point1.txt" 'variable
  Set myCell = Range("$N$1")
  
  With ActiveSheet.QueryTables.Add _
      (Connection:=csvPath, Destination:=myCell) 'csvPath variable
        .Name = "SCHNITT-STREIFEN_" & Format(nFile, "000") & "_point1"  'variable
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .RefreshPeriod = 0
        .TextFilePlatform = 850
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileDecimalSeparator = "."
        .TextFileThousandsSeparator = " "
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
  End With
  
  Call DoFormatTxtImport(myCell)
    
  Range("N1:R1").FormulaR1C1 = "Pull -> Point 1"
'**************************************************************************
Rem warum zu guter Letzt diese Zeile - Löschung ?
  Rows("3:3").Delete Shift:=xlUp
'**************************************************************************
txtImport_2 = True
Exit Function
NoQuerry:
MsgBox "Fehler im Modul txtImport_2 bei Tabelle" & Chr(13) & csvPath
End Function


Function txtImport_1(ByVal nFile As Integer) As Boolean
Const csvDir As String = "Z:\Streifenziehanlage\Versuche 21.01.2014\Aramis-Daten\SCHNITT-STREIFEN_"
Const csvCon As String = "TEXT;"
Dim csvPath As String
Dim myCell As Range
On Error GoTo NoQuerry

  csvPath = csvCon & csvDir & Format(nFile, "000") & "_point0.txt" 'variable
  Set myCell = Range("$H$1")
  
  With ActiveSheet.QueryTables.Add _
      (Connection:=csvPath, Destination:=myCell) 'csvPath variable
        .Name = "SCHNITT-STREIFEN_" & Format(nFile, "000") & "_point0"  'variable
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileDecimalSeparator = "."
        .TextFileThousandsSeparator = " "
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
  End With
  
  Call DoFormatTxtImport(myCell)
  
  Range("H1").Formula = "Back -> Point 0"
  
txtImport_1 = True
Exit Function
NoQuerry:
MsgBox "Fehler im Modul txtImport_1 bei Tabelle" & Chr(13) & csvPath
End Function

Function csvImport_Messdaten(ByVal nFile As Integer) As Boolean
'
' Import_Messdaten Makro
'
'my modification
Const csvDir As String = "Z:\Streifenziehanlage\Versuche 21.01.2014\HBM-Daten\"
Const csvCon As String = "TEXT;"
Dim x As Long
Dim csvPath As String
On Error GoTo NoQuerry

  csvPath = csvCon & csvDir & Format(nFile, "000") & ".csv" 'variable
  Sheets.Add
    ActiveSheet.Name = "Versuch_" & Format(nFile, "000") 'variable
    With ActiveSheet.QueryTables.Add _
      (Connection:=csvPath, Destination:=Range("$A$2")) 'variable
        .Name = Format(nFile, "000")  'variable
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False 'change if semicolon
        .TextFileCommaDelimiter = True  'change if not comma
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    Range("A2:F2").HorizontalAlignment = xlCenter
    Range("A2:B2").Merge
    Range("C2:D2").Merge
    Range("E2:F2").Merge
   
    With Range("A1:F1")
      .HorizontalAlignment = xlCenter
      .Merge
      .Font.Size = 12
      .Font.Bold = True
      .Formula = "Versuch_" & Format(nFile, "000") 'variable
      With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
      End With
    End With
    
    Columns("A:F").ColumnWidth = 12
    Columns("G:G").Select
    Selection.ColumnWidth = 2
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("H1").Select
csvImport_Messdaten = True
Exit Function
NoQuerry:
MsgBox "Fehler im Modul csvImport_Messdaten bei Tabelle" & Chr(13) & csvPath
End Function