Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1204to1208
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

viele *.csv Dateien nacheinander öffnen

viele *.csv Dateien nacheinander öffnen
Johannes
Hallo zusammen,
mein Problem sind extrem viele *.csv Dateien mit den Rohwerten einer jeden einzelnen Messung (Kraft - Weg Messwerte ~ 1500 je Messung).
Mein Code ist in der Lage die Messwerte aus der offenen Datei zu holen und in einer zusammenfassenden Exceldatei einzufügen. Das Problem liegt darin, dass die *.csv Dateien im Verzeichnis c:\Rohwerte liegen und natürlich jede Datei einen anderen Namen hat.
Ich suche nun nach einer Möglichkeit dass der Code einfach die erste *.csv-Datei öffnet, das Auslesen der Daten durchzieht und die *.csv-Datei anschließend wieder schließt und sich dann die nächste nimmt, und das sooft wie es *.csv-Dateien im Verzeichnis gibt.
Leider konnte ich bisher nichts herausfinden, um das Problem zu lösen. Kann mir jemand von Euch hier weiterhelfen? Für Eure Mühe schon jetzt recht herzlichen Dank.
Gruß
Johannes
AW: viele *.csv Dateien nacheinander öffnen
Martin
Hallo Johannes,
klar bekommen wir das hin. Poste mal bitte deinen Code, damit alles reibungslos klappt.
Viele Grüße
Martin
AW: viele *.csv Dateien nacheinander öffnen
Rudi
Hallo,
so in der Art:
Sub Rohdaten_Importieren()
Dim strFileName As String, arrDaten, arrTmp, lngR As Long
Const cstrDelim As String = ";" 'Trennzeichen
Const cstrPath As String = "c:\Rohdaten\"
strFileName = Dir(cstrPath & "*.csv")
Do While strFileName  ""
Application.ScreenUpdating = False
Open cstrPath & strFileName For Input As #1
arrDaten = Split(Input(LOF(1), 1), vbCrLf)
Close #1
For lngR = 1 To UBound(arrDaten)
arrTmp = Split(arrDaten(lngR), cstrDelim)
If UBound(arrTmp) > -1 Then
Sheets(1).Cells(Rows.Count, 1).End(xlUp) _
.Offset(1).Resize(, UBound(arrTmp) + 1) _
= Application.Transpose(Application.Transpose(arrTmp))
End If
Next lngR
Loop
End Sub

Gruß
Rudi
Anzeige
AW: viele *.csv Dateien nacheinander öffnen
Johannes
Hallo Rudi,
irgendwo klemmt es noch, denn Dein Code (ohne meine Einfügung) bringt lediglich eine nicht endende Eieruhr, mit meiner Zeile bleibt mein Code bei Range("B1").FormulaR1C1 = "=SUM(R[149]C:R[1148]C)"
hängen.
Könntest Du bitte nochmal drübersehen was da nicht klappt. Danke
Gruß
Johannes
Code:
Sub Rohdaten_Importieren()
Dim strFileName As String, arrDaten, arrTmp, lngR As Long
Const cstrDelim As String = ";" 'Trennzeichen
Const cstrPath As String = "E:\Rohdaten\"
strFileName = Dir(cstrPath & "*.csv")
Do While strFileName  ""
Application.ScreenUpdating = False
Open cstrPath & strFileName For Input As #1
arrDaten = Split(Input(LOF(1), 1), vbCrLf)
Close #1
For lngR = 1 To UBound(arrDaten)
arrTmp = Split(arrDaten(lngR), cstrDelim)
If UBound(arrTmp) > -1 Then
Sheets(1).Cells(Rows.Count, 1).End(xlUp) _
.Offset(1).Resize(, UBound(arrTmp) + 1) _
= Application.Transpose(Application.Transpose(arrTmp))
End If
Next lngR
'Zeile von mir eingefügt
Call Daten_Lesen
'Ende einfügen
Loop
End Sub
Sub Daten_Lesen()
Dim NAM As Variant  'Dateiname
Dim SUM As Variant  'Summe über Messwerte Kraft
Dim ZEI As Variant  'Zeit der Messung
Dim DAT As Variant  'Datum der Messung
Dim ERG As Variant  'Ergebnis der Messung
Range("B1").FormulaR1C1 = "=SUM(R[149]C:R[1148]C)"
Range("B1").NumberFormat = "#,##0"
Range("B2").FormulaR1C1 = "=TEXT(R[5]C,""JJJJ-MM-TT"")&""-""&TEXT(R[4]C,""hh-mm-ss"")"
NAM = Range("B2").Value
SUM = Range("B1").Value
ZEI = Range("B6").Value
DAT = Range("B7").Value
ERG = Range("B10").Value
ActiveWorkbook.SaveAs Filename:= _
"E:\Rohdaten\" & NAM & ".xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Range("B149:B1286").Select
Selection.Copy
Workbooks.Open Filename:= _
"E:\Rohdaten\Auswertung Rohdaten.xls"
Windows("Auswertung Rohdaten.xls").Activate
Range("A6").Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
Range("A1").Value = NAM
Range("A2").Value = SUM
Range("A3").Value = ZEI
Range("A4").Value = DAT
Range("A5").Value = ERG
Columns("A").Select
Selection.Insert Shift:=xlToRight
Range("B3").NumberFormat = "h:mm:ss"
Range("B2").NumberFormat = "#,##0.00"
Range("B1").Select
With Selection
.Orientation = -90
.HorizontalAlignment = xlCenter
End With
Columns("B:B").EntireColumn.AutoFit
Range("A1").Select
ActiveWorkbook.Save
ActiveWindow.Close
Windows(NAM & ".xls").Activate
ActiveWorkbook.Save
ActiveWindow.Close
End Sub

Anzeige
da hab ich doch glatt ...
Rudi
Hallo,
eine Zeile vergessen.
Sub Rohdaten_Importieren()
Dim strFileName As String, arrDaten, arrTmp, lngR As Long
Const cstrDelim As String = ";" 'Trennzeichen
Const cstrPath As String = "E:\Rohdaten\"
strFileName = Dir(cstrPath & "*.csv")
Do While strFileName  ""
Application.ScreenUpdating = False
Open cstrPath & strFileName For Input As #1
arrDaten = Split(Input(LOF(1), 1), vbCrLf)
Close #1
For lngR = 1 To UBound(arrDaten)
arrTmp = Split(arrDaten(lngR), cstrDelim)
If UBound(arrTmp) > -1 Then
Sheets(1).Cells(Rows.Count, 1).End(xlUp) _
.Offset(1).Resize(, UBound(arrTmp) + 1) _
= Application.Transpose(Application.Transpose(arrTmp))
End If
Next lngR
strFileName = Dir
'Zeile von mir eingefügt
Call Daten_Lesen
'Ende einfügen
Loop
End Sub

Gruß
Rudi
Anzeige
AW: da hab ich doch glatt ...
Johannes
Hallo Rudi,
das klappt leider noch nicht. Frage: an der zitierten Stelle soll die *.csv geöffnet werden und in der nächsten Zeile gleich wieder geschlossen ? Müsste nicht hier mein Code dazwischen, oder habe ich da einen Denkfehler?
Open cstrPath & strFileName For Input As #1
arrDaten = Split(Input(LOF(1), 1), vbCrLf)
Close #1
Gruß
Johannes
Denkfehler
Rudi
Hallo,
ich hatte einen.
Zu meinem Code:
Der geht einfach hin ud liest die Daten aus allen .csv im Ordner und schreibt sie untereinander in eine Tabelle. Die .csv wird dabei in Excel gar nicht geöffnet. Von daher rasend schnell.
Wenn du mal eine .csv hochlädst, kann ich das auch für deine Auswertung so machen.
Gruß
Rudi
Anzeige
Thema verfehlt
Rudi
Hallo,
ich glaube, du willst das so:
Sub Daten_Lesen()
Dim NAM As Variant  'Dateiname
Dim SUM As Variant  'Summe über Messwerte Kraft
Dim ZEI As Variant  'Zeit der Messung
Dim DAT As Variant  'Datum der Messung
Dim ERG As Variant  'Ergebnis der Messung
Dim sFile As String, wkbCSV As Workbook, wkbROH As Workbook
Const sPfad As String = "e:\rohdaten\"
sFile = Dir(sPfad & "*.csv")
If sFile  "" Then
Application.ScreenUpdating = False
Set wkbROH = Workbooks.Open("E:\Rohdaten\Auswertung Rohdaten.xls")
Do While sFile  ""
Set wkbCSV = Workbooks.Open(sPfad & sFile)
With wkbCSV.Sheets(1)
.Range("B1").FormulaR1C1 = "=SUM(R[149]C:R[1148]C)"
.Range("B1").NumberFormat = "#,##0"
.Range("B2").FormulaR1C1 = "=TEXT(R[5]C,""JJJJ-MM-TT"")&""-""&TEXT(R[4]C,""hh-mm-ss"")"
NAM = .Range("B2").Value
SUM = .Range("B1").Value
ZEI = .Range("B6").Value
DAT = .Range("B7").Value
ERG = .Range("B10").Value
.Range("B149:B1286").Copy wkbROH.Sheets(1).Range("A6")
.SaveAs Filename:=sPfad & NAM & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
.Parent.Close
End With
With wkbROH.Sheets(1)
With .Range("A1")
.Value = NAM
.Orientation = -90
.HorizontalAlignment = xlCenter
End With
.Range("A2").Value = SUM
.Range("A3").Value = ZEI
.Range("A4").Value = DAT
.Range("A5").Value = ERG
.Range("A3").NumberFormat = "h:mm:ss"
.Range("A2").NumberFormat = "#,##0.00"
.Columns(1).EntireColumn.AutoFit
.Columns(1).Insert Shift:=xlToRight
.Parent.Save
End With
Loop
wkbROH.Close True
End If
End Sub

Gruß
Rudi
Anzeige
AW: Thema verfehlt
Johannes
Hallo Rudi,
da haben sich mein Testen und Dein Posting überschnitten. Leider öffnet Dein Code die *.csv nicht so dass ich die Daten richtig vorliegen habe. Ich habe die Auswertedatei:
https://www.herber.de/bbs/user/73986.xls
mal hochgeladen und Tabellen 2 und 3 enthalten die unterschiedlich geöffneten Daten der selben *.csv. Leider lässt sich eine *.csv als Original nicht hochladen.
in Tabelle 1 die Daten so wie sie sein sollen
in Tabelle 2 die Daten der *.csv geöffnet mit code von Rudi
in Tabelle 3 die daten der *.csv mit meinem Code geöffnet
Kannst Du Dir das nochmal ansehen. Danke
Gruß
Johannes
Anzeige
.csv hochladen
Rudi
Hallo,
benenne sie in .txt um.
Gruß
Rudi
AW: .csv hochladen
Johannes
Hallo Rudi,
ich muss mich oben korrigieren:
Wenn ich die *.csv öffne indem ich
- Datei öffnen
-- alle Dateien (auswählen)
--- eine Datei markieren und OK
dann öffnet sich die Datei so wie in Tabelle 3 - alle meine Versuche sie über VBA zu öffnen bringen das gleiche Ergebnis wie bei Dir in Tabelle 2
Scheint also wohl mit dem Öffnen-Dialog zusammenzuhängen.
hier die als *.txt umgewandelte .csv
https://www.herber.de/bbs/user/73990.txt
Gruß
Johannes
Anzeige
AW: Thema verfehlt
Rudi
Hallo,
ändre mal:
      Do While sFile  ""
Set wkbCSV = Workbooks.Open(sPfad & sFile), local:=True
With wkbCSV.Sheets(1)

Gruß
Rudi
AW: Thema verfehlt
Johannes
Hallo Rudi,
mein Excel stört sich an dem "Komma"
Set wkbCSV = Workbooks.Open(sPfad & sFile) -> , local:=True
und behauptet "Fehler beim Komiplieren. Erwartet: Anweisungsende"
Sorry
Gruß
Johannes
AW: Thema verfehlt
Rudi
Hallo,
sorry, gehört in die ()
Set wkbCSV = Workbooks.Open(sPfad & sFile, local:=True)
Gruß
Rudi
neuer Weg (Schnellstraße)
Rudi
Hallo,
50x deine hochgeladene Datei in weniger als 3 Sek:
Sub Johannes()
Dim arrRoh, arrTmp, arrDaten(), n As Integer, i As Integer
Dim sFile As String, wksAusw As Worksheet, dblSum As Double
Const sPfad As String = "c:\test\Joh\"
Const sDelim As String = ";"
Application.ScreenUpdating = False
'Auswertedatei öffnen
Set wksAusw = Workbooks.Open("e:\rohdaten\auswertung rohdaten.xls").Sheets(1)
With wksAusw
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
Exit Sub
End If
End With
sFile = Dir(sPfad & "*.csv")
Do While sFile  ""
dblSum = 0
Open sPfad & sFile For Input As #1
arrRoh = Split(Input(LOF(1), 1), vbLf)
Close #1
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = Format(CDate(Split(arrRoh(5), sDelim)(1)), "hh:mm:ss")
arrDaten(1, 4) = Format(CDate(Split(arrRoh(6), sDelim)(1)), "YYYY.MM.DD")
arrDaten(1, 1) = Format(CDate(arrDaten(1, 4)) + CDate(arrDaten(1, 3)), _
"YYYY-MM-DD-hh-mm-ss")
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
n = 6
For i = 149 To UBound(arrRoh) - 1
arrTmp = Split(arrRoh(i), sDelim)
n = n + 1
dblSum = dblSum + arrTmp(1)
arrDaten(1, n) = arrTmp(1)
Next
ReDim Preserve arrDaten(1 To 1, 1 To n)
arrDaten(1, 2) = Round(dblSum, 2)
With wksAusw
.Cells(1, 1).Resize(n) = Application.Transpose(arrDaten)
.Cells(1, 1).Orientation = 90
.Cells(2, 1).NumberFormat = "#,##0.00"
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
.Columns(1).AutoFit
.Columns(1).Insert
End With
sFile = Dir
Loop
wksAusw.Parent.Save
End Sub

Gruß
Rudi
Anzeige
AW: neuer Weg (Schnellstraße)
Johannes
Hallo Rudi,
... aber leider mit "Schlaglöchern" ;-) nix für ungut
Bei mir kommt folgende Fehler:
https://www.herber.de/bbs/user/73991.xls
wobei ich den Pfad von
Const sPfad As String = "c:\test\Joh\"
in
Const sPfad As String = "e:\rohdaten\"
geändert hatte. Leider aber das gleiche Ergebnis.
Gruß
Johannes
Schlagloch
Rudi
Hallo,
kann ich nicht nachvollziehen.
2000 hab ich leider nicht, aber unter XP und 2007 läuft's mit der Datei.
Ist die Original, nur umbenannt?
Gruß
Rudi
AW: Schlagloch
Johannes
Guten Morgen Rudi,
ja die Datei wurde einfach nur umbenannt.
Gruß
Johannes
Anzeige
Schlaglöcher repariert?
Erich
Hi Johannes,
probier mal diese Version:

Sub Johannes2()
Dim arrRoh, arrTmp, arrDaten(), n As Integer, i As Integer
Dim sFile As String, wksAusw As Worksheet, dblSum As Double
Const sPfad As String = "c:\test\Joh\"
Const sDelim As String = ";"
'  Application.ScreenUpdating = False ' ist m.E. überflüssig
'Auswertedatei öffnen
Set wksAusw = Workbooks.Open("e:\rohdaten\auswertung rohdaten.xls").Sheets(1)
With wksAusw
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
Exit Sub
End If
End With
sFile = Dir(sPfad & "*.csv")
Do While sFile  ""
dblSum = 0
Open sPfad & sFile For Input As #1
arrRoh = Split(Input(LOF(1), 1), vbLf)
Close #1
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = CDbl(CDate(Split(arrRoh(5), sDelim)(1)))
arrDaten(1, 4) = CDbl(CDate(Split(arrRoh(6), sDelim)(1)))
arrDaten(1, 1) = Format(CDate(arrDaten(1, 4)) + CDate(arrDaten(1, 3)), _
"YYYY-MM-DD-hh-mm-ss")
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
n = 6
For i = 149 To UBound(arrRoh) - 1
arrTmp = Split(arrRoh(i), sDelim)
n = n + 1
dblSum = dblSum + arrTmp(1)
arrDaten(1, n) = 1 * arrTmp(1)
Next
ReDim Preserve arrDaten(1 To 1, 1 To n)
arrDaten(1, 2) = Round(dblSum, 2)
With wksAusw
.Cells(1, 1).Resize(n) = Application.Transpose(arrDaten)
.Cells(1, 1).Orientation = 90
.Cells(2, 1).NumberFormat = "#,##0.00"
.Cells(3, 1).NumberFormat = "hh:mm:ss"
.Cells(4, 1).NumberFormat = "DD.MM.YYYY"
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
.Columns(1).AutoFit
.Columns(1).Insert
End With
sFile = Dir
Loop
wksAusw.Parent.Save
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
AW: Schlaglöcher repariert? leider nein
Johannes
Hallo Erich,
der Code hängt in der Zeile:
arrDaten(1, 1) = Format(CDate(arrDaten(1, 4)) + CDate(arrDaten(1, 3)), _
mit Fehlermeldung:
"Falsche Anzahl an Argumenten oder ungültige Zuweisung einer Eigenschaft"
das Wort "Format" ist blau unterlegt.
Ich hoffe Dir sagt das was - mir leider nicht.
Gruß
Johannes
jetzt vielleicht?
Erich
Hi Johannes,
dann ersetze bitte diese Zeile durch

arrDaten(1, 1) = Format(arrDaten(1, 4) + arrDaten(1, 3), _
"YYYY-MM-DD-hh-mm-ss")
Was soll eigentlich in A1 nachher stehen?
Datum und Uhrzeit als Zahl im Format JJJJ-MM-TT-hh-mm-ss oder ein Text, der so ähnlich aussieht?
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
AW: jetzt vielleicht?
Johannes
Hallo Erich,
ich habe die betreffende Zeile einfach mal auskommentiert. Dann läuft der Code und zwar rasend schnell. Allerdings erkennt er nicht, wenn die Auswertedatei voll ist, sondern bringt dann die Fehlermeldung
"Microsoft Excel kann ausgefüllte Zellen nicht über das Blatt hinaus verschieben ...."
Der Code steht dann in Zeile .Columns(1).Insert
Das ist aktuell zwar ein Schönheitsfehler, aber nicht wirklich tragisch. Ich werde halt sehen, dass eben nicht mehr Dateien im Verzeichnis sind, als die Auswertedatei Spalten hat ;-) .
Zum Inhalt der Zelle A1 hatte ich mir gedacht, dass ich aus dem Datensatz der Datum und Uhrzeit der Messung enthält in einer Zelle diese Daten verknüpfe um dann diese Information als Suchkriterium zu nutzen um genau diese Kurve genauer ansehen zu können.
Die Messwerte stammen aus einer Servomotorischen Fügevorrichtung, die den Weg und die Kraft an den 1000 Messpunkten mitschreibt. Ziel ist es auffällige Teile und deren Kraft-Weg-Kurven zu erkennen und der Steuerung ein oder mehrere Fenster in der Kurve zu definieren die nicht durchlaufen werden dürfen - und wenn doch, dann ist der Fügevorgang fehlerhaft.
Bis dahin werden die Teile schön sortiert abgelegt und begutachtet und wenn eines auffällig ist die Kurves dieses Teils dann im Vergleich zu der Masse der anderen verglichen um "hoffentlich" eine Systematik ableiten zu können.
Gruß
Johannes
neuer Reparaturversuch
Rudi
Hallo,
anscheinend hat XL2000 Probs mit der Format-Funktion
Evtl. so:
Sub Johannes()
Dim arrRoh, arrTmp, arrDaten(), n As Integer, i As Integer
Dim sFile As String, wksAusw As Worksheet, dblSum As Double
Const sPfad As String = "c:\test\Joh\"
Const sDelim As String = ";"
Application.ScreenUpdating = False
'Auswertedatei öffnen
Set wksAusw = Workbooks.Open("e:\rohdaten\auswertung rohdaten.xls").Sheets(1)
With wksAusw
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
Exit Sub
End If
End With
sFile = Dir(sPfad & "*.csv")
Do While sFile  ""
dblSum = 0
Open sPfad & sFile For Input As #1
arrRoh = Split(Input(LOF(1), 1), vbLf)
Close #1
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = Format(CDate(Split(arrRoh(5), sDelim)(1)), "hh:mm:ss")
arrDaten(1, 4) = Format(CDate(Split(arrRoh(6), sDelim)(1)), "YYYY.MM.DD")
arrDaten(1, 1) = CDate(arrDaten(1, 4)) + CDate(arrDaten(1, 3))
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
n = 6
For i = 149 To UBound(arrRoh) - 1
arrTmp = Split(arrRoh(i), sDelim)
n = n + 1
dblSum = dblSum + arrTmp(1)
arrDaten(1, n) = arrTmp(1)
Next
ReDim Preserve arrDaten(1 To 1, 1 To n)
arrDaten(1, 2) = Round(dblSum, 2)
With wksAusw
.Cells(1, 1).Resize(n) = Application.Transpose(arrDaten)
With .Cells(1, 1)
.Orientation = 90
.NumberFormat = "YYYY-MM-DD-hh-mm-ss"
.Value = .Text
End With
.Cells(2, 1).NumberFormat = "#,##0.00"
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
.Columns(1).AutoFit
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
wksAusw.Parent.Save
Exit Sub
Else
.Columns(1).Insert
End If
End With
sFile = Dir
Loop
wksAusw.Parent.Save
End Sub

Gruß
Rudi
Ihr habt es geschafft !
Johannes
Hallo Rudi,
mein Excel verhält sich schon komisch, mit Deinem Code kommt es bei den auskommentierten Zeile zu Störungen, wenn ich jedoch diese beiden Zeile durch die alten ersetze läft der Code - auch die "Vollmeldung" kommt.
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = CDbl(CDate(Split(arrRoh(5), sDelim)(1)))
arrDaten(1, 4) = CDbl(CDate(Split(arrRoh(6), sDelim)(1)))
'arrDaten(1, 3) = Format(CDate(Split(arrRoh(5), sDelim)(1)), "hh:mm:ss")
'arrDaten(1, 4) = Format(CDate(Split(arrRoh(6), sDelim)(1)), "YYYY.MM.DD")
arrDaten(1, 1) = CDate(arrDaten(1, 4)) + CDate(arrDaten(1, 3))
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
Das die Zellen mit Datum und Zeit noch im Zahlenformat stehen ist aber nicht wirklich tragisch, das sind nur wenige Handgriffe an der gefüllten Datei um die beiden Zeilen zu formatieren.
Das im Code noch zu korrigieren ist "nur noch sportlicher Ehrgeiz" es doch noch zu schaffen - ich würde verstehen, wenn das reizt - es ist aber nicht wirklich erforderlich.
Ich möchte mich ganz herzlich für Deine und Erichs Hilfe bedanken - das hätte ich alleine nie hinbekommen.
Gruß
Johannes
Final Code
Rudi
Hallo,
Zeit- und Datumsformat wird gesetzt.
Zusätzlich werden die verarbeiteten Dateien mit _x gekennzeichnet.
Sub Johannes2()
Dim arrRoh, arrTmp, arrDaten(), n As Integer, i As Integer
Dim sFile As String, wksAusw As Worksheet, dblSum As Double
Const sPfad As String = "f:\Joh\"
Const sDelim As String = ";"
Application.ScreenUpdating = False
'Auswertedatei öffnen
Set wksAusw = Workbooks.Open("f:\joh\auswertung rohdaten.xls").Sheets(1) '("e:\rohdaten\ _
auswertung rohdaten.xls").Sheets(1)
With wksAusw
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
Exit Sub
End If
End With
sFile = Dir(sPfad & "*.csv")
Do While sFile  ""
dblSum = 0
Open sPfad & sFile For Input As #1
arrRoh = Split(Input(LOF(1), 1), vbLf)
Close #1
Name sPfad & sFile As sPfad & sFile & "_x" 'als verarbeitet kennzeichnen
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = CDbl(CDate(Split(arrRoh(5), sDelim)(1)))
arrDaten(1, 4) = CDbl(CDate(Split(arrRoh(6), sDelim)(1)))
arrDaten(1, 1) = arrDaten(1, 3) + arrDaten(1, 4)
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
n = 6
For i = 149 To UBound(arrRoh) - 1
arrTmp = Split(arrRoh(i), sDelim)
n = n + 1
dblSum = dblSum + arrTmp(1)
arrDaten(1, n) = arrTmp(1)
Next
ReDim Preserve arrDaten(1 To 1, 1 To n)
arrDaten(1, 2) = Round(dblSum, 2)
With wksAusw
.Cells(1, 1).Resize(n) = Application.Transpose(arrDaten)
With .Cells(1, 1)
.Orientation = 90
.NumberFormat = "YYYY-MM-DD-hh-mm-ss"
.Value = .Text
End With
.Cells(2, 1).NumberFormat = "#,##0.00"
.Cells(3, 1).NumberFormat = "hh:mm:ss"
.Cells(4, 1).NumberFormat = "DD.MM.YYYY"
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
.Columns(1).AutoFit
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
wksAusw.Parent.Save
Exit Sub
Else
.Columns(1).Insert
End If
End With
sFile = Dir
Loop
wksAusw.Parent.Save
End Sub

Gruß
Rudi
kleine Unterschiede
Erich
Hi Rudi,
unsere beiden Versionen unterscheiden sich an wenigen Stellen:
In A1 schreibt dein Code letztlich einen Text (mit .Value = .Text).
Danach ist das Format der Zelle ziemlich gleichgülltig.
Mein Code schreibt einen Zahlwert für Datum und Uhrzeit in A1 und formatiert als Datum/Uhrzeit.
In A7:A1006 schreibt dein Code Texte (arrTmp(1) ist ein String),
meine Version schreibt Zahlen (1 * arrTmp(1)).
Ist es wirklich nötig, am Anfang und am Ende zu prüfen, ob .Cells(1, Columns.Count) leer ist?
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
.Cells(1, Columns.Count) prüfen
Rudi
Hallo,
ich denke schon. Sonst hakt es bei .Columns(1).Insert
In A7:A1006 schreibt dein Code Texte (arrTmp(1) ist ein String), 

stimmt, wird aber anscheinend durch Excel korrigiert. Bei echten Texten würde
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
nicht wirken. Tut es aber. arrTmp(1) mit 1 zu multiplizieren ist aber sicherer.
Gruß
Rudi
Zahlformat für Text-Werte?
Erich
Hi Rudi,
"wird aber anscheinend durch Excel korrigiert.
Bei echten Texten würde .Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
nicht wirken. Tut es aber."
Das glaube ich nicht, das scheint nur so. arrTmp(1) ist ein echter Text.
Probier doch mal, diese Texte als Prozente oder wissenschaftlich zu formatieren.
Das klappt nur, wenn es keine Texte, sondern Zahlen sind, also z. B. = 1 * arrTmp(1).
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
als % formatiert
Rudi
Hallo Erich,
kein Problem. Klappt
Gruß
Rudi
Danke, jetzt ist es perfekt !!
Johannes
Hallo Rudi,
das war jetzt noch das Sahnehäubchen oben auf.
Vielen, vielen Dank
Gruß
Johannes
Perfekt ist anders
Rudi
Hallo,
siehe meine Diskussion mit Erich.
wirklich nur .csv:
Sub Johannes2()
Dim arrRoh, arrTmp, arrDaten(), n As Integer, i As Integer
Dim sFile As String, wksAusw As Worksheet, dblSum As Double
Const sPfad As String = "f:\Joh\"
Const sDelim As String = ";"
Application.ScreenUpdating = False
sFile = Dir(sPfad & "*.csv", vbNormal)
Do While sFile  ""
If Right(sFile, 4) = ".csv" Then
If wksAusw Is Nothing Then
'Auswertedatei öffnen
Set wksAusw = Workbooks.Open("f:\joh\auswertung rohdaten.xls").Sheets(1) '("e:\rohdaten\ _
auswertung rohdaten.xls").Sheets(1)
With wksAusw
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
Exit Sub
End If
End With
End If
dblSum = 0
Open sPfad & sFile For Input As #1
arrRoh = Split(Input(LOF(1), 1), vbLf)
Close #1
Name sPfad & sFile As sPfad & sFile & "_x" 'als verarbeitet kennzeichnen
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = CDbl(CDate(Split(arrRoh(5), sDelim)(1)))
arrDaten(1, 4) = CDbl(CDate(Split(arrRoh(6), sDelim)(1)))
arrDaten(1, 1) = arrDaten(1, 3) + arrDaten(1, 4)
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
n = 6
For i = 149 To UBound(arrRoh) - 1
arrTmp = Split(arrRoh(i), sDelim)
n = n + 1
dblSum = dblSum + arrTmp(1)
arrDaten(1, n) = arrTmp(1) * 1
Next
ReDim Preserve arrDaten(1 To 1, 1 To n)
arrDaten(1, 2) = Round(dblSum, 2)
With wksAusw
.Cells(1, 1).Resize(n) = Application.Transpose(arrDaten)
With .Cells(1, 1)
.Orientation = 90
.NumberFormat = "YYYY-MM-DD-hh-mm-ss"
.Value = .Text
End With
.Cells(2, 1).NumberFormat = "#,##0.00"
.Cells(3, 1).NumberFormat = "hh:mm:ss"
.Cells(4, 1).NumberFormat = "DD.MM.YYYY"
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
.Columns(1).AutoFit
If .Cells(1, Columns.Count)  "" Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
wksAusw.Parent.Save
Exit Sub
Else
.Columns(1).Insert
End If
End With
End If
sFile = Dir
Loop
If wksAusw Is Nothing Then
MsgBox "Keine Dateien vorhanden.", , "Gebe bekannt ..."
Else
wksAusw.Parent.Save
End If
End Sub

Gruß
Rudi
Geschafft? mal sehen...
Erich
Hi Johannes,
tut es dieser Code?

Sub Johannes2()
Dim arrRoh, arrTmp, arrDaten(), n As Integer, i As Integer
Dim sFile As String, wksAusw As Worksheet, dblSum As Double
Const sPfad As String = "c:\test\Joh\"
Const sDelim As String = ";"
'Auswertedatei öffnen
Set wksAusw = Workbooks.Open("e:\rohdaten\auswertung rohdaten.xls").Sheets(1)
With wksAusw
If Not IsEmpty(.Cells(1, Columns.Count)) Then
MsgBox "Auswertung ist voll!", vbCritical, "ACHTUNG"
Exit Sub
End If
End With
sFile = Dir(sPfad & "*.csv")
Do While sFile  ""
dblSum = 0
Open sPfad & sFile For Input As #1
arrRoh = Split(Input(LOF(1), 1), vbLf)
Close #1
ReDim arrDaten(1 To 1, 1 To UBound(arrRoh))
arrDaten(1, 3) = CDbl(CDate(Split(arrRoh(5), sDelim)(1)))
arrDaten(1, 4) = CDbl(CDate(Split(arrRoh(6), sDelim)(1)))
arrDaten(1, 1) = arrDaten(1, 4) + arrDaten(1, 3)
arrDaten(1, 5) = Split(arrRoh(9), sDelim)(1)
arrDaten(1, 6) = Split(arrRoh(148), sDelim)(1)
n = 6
For i = 149 To UBound(arrRoh) - 1
arrTmp = Split(arrRoh(i), sDelim)
n = n + 1
dblSum = dblSum + arrTmp(1)
arrDaten(1, n) = 1 * arrTmp(1)
Next
ReDim Preserve arrDaten(1 To 1, 1 To n)
arrDaten(1, 2) = Round(dblSum, 2)
With wksAusw
.Cells(1, 1).Resize(n) = Application.Transpose(arrDaten)
With .Cells(1, 1)
.Orientation = 90
.NumberFormat = "DD.MM.YYYY hh:mm:ss"
End With
.Cells(2, 1).NumberFormat = "#,##0.00"
.Cells(3, 1).NumberFormat = "hh:mm:ss"
.Cells(4, 1).NumberFormat = "DD.MM.YYYY"
.Cells(7, 1).Resize(n - 6).NumberFormat = "#,##0.00"
.Columns(1).AutoFit
.Columns(1).Insert
End With
sFile = Dir
Loop
wksAusw.Parent.Save
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Hast du ne Ahnung ...
Rudi
Hallo Erich,
... warum sFile = Dir(sPfad & "*.csv") auch Files, die auf .csv_x enden auswirft?
sFile= "Joh.csv_x"
Gruß
Rudi
Überhaupt keine!
Erich
Hi Rudi,
ich habe durch deinen Post gerade erst festgestellt, dass mein Textfile inzwischen 73990.csv_x_x heißt,
und die Routinen verarbeiten es weiter.
Ich bin einfach nur verblüfft, dachte, wenigstens den Befehl "Dir()" einigermaßen zu kennen :-(
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Wenn man ...
Rudi
Hallo,
... anstatt _ . nimmt, klappt es.
Name sPfad & sFile As sPfad & sFile & ".x"
Anscheinend wird der letzte . im Dateinamen genommen und nur bis zu Länge des Suchkriteriums verglichen.
sfile = Dir("c:\test\*.jpg") bringt auch Bild1.jpgabcde, Bild2.jpg123 etc. aber nicht Bild3.jpg.xxx
Gruß
Rudi

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige