Thema Datum  Von Nutzer Rating
Antwort
14.02.2014 11:48:01 Tolis
NotSolved
14.02.2014 13:49:03 Gast15049
NotSolved
14.02.2014 14:51:49 Gast51863
NotSolved
14.02.2014 18:56:21 H27
NotSolved
15.02.2014 15:24:24 Tolis
NotSolved
Blau Import & Auswertung von CSV/TXT Files mit VBA
17.02.2014 10:16:45 H27
NotSolved

Ansicht des Beitrags:
Von:
H27
Datum:
17.02.2014 10:16:45
Views:
1111
Rating: Antwort:
  Ja
Thema:
Import & Auswertung von CSV/TXT Files mit VBA

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

 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
'**************************************************************************
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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
14.02.2014 11:48:01 Tolis
NotSolved
14.02.2014 13:49:03 Gast15049
NotSolved
14.02.2014 14:51:49 Gast51863
NotSolved
14.02.2014 18:56:21 H27
NotSolved
15.02.2014 15:24:24 Tolis
NotSolved
Blau Import & Auswertung von CSV/TXT Files mit VBA
17.02.2014 10:16:45 H27
NotSolved