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
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"
Set
myCell = Range(
"$N$1"
)
With
ActiveSheet.QueryTables.Add _
(Connection:=csvPath, Destination:=myCell)
.Name =
"SCHNITT-STREIFEN_"
& Format(nFile,
"000"
) &
"_point1"
.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"
Set
myCell = Range(
"$H$1"
)
With
ActiveSheet.QueryTables.Add _
(Connection:=csvPath, Destination:=myCell)
.Name =
"SCHNITT-STREIFEN_"
& Format(nFile,
"000"
) &
"_point0"
.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
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"
Sheets.Add
ActiveSheet.Name =
"Versuch_"
& Format(nFile,
"000"
)
With
ActiveSheet.QueryTables.Add _
(Connection:=csvPath, Destination:=Range(
"$A$2"
))
.Name = Format(nFile,
"000"
)
.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
.TextFileCommaDelimiter =
True
.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"
)
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