Hallo VBA-Profis,
ich bin Student und beschäftige mich gerade damit Messwerte einer Versuchskälteanlage auszuwerten. Dazu muss ich täglich mehere Spalten aus 8 verschiedenen Datein in eine "Gesamtdatei" kopieren. Ein Spalte enthält etwa 1500 Zahlenwerte.
Alle einzelnen Datein sind so aufgebaut: Datum, Uhrzeit, 1-6 Messwerte. Die Daten sind mit einem Semikolon getrennt und werde als *.csv Datei gespeichert. Die Gesamtdatei soll als *.xls ausgegeben werden.
In den csv Datein werden die gesamten Messwerte einer ganzen Woche abgespechert. Die Gesamtdatei soll jeweils nur einen Tag abdecken.
Ziel soll sein, dass alle Messwerte eines Tages in seperaten Spalten in eine Gesamtdatei kopiert werden. In der Gesamtdatei sollen dann über hinterlegten Formeln die Leistung usw. berechnet und die Werte als Diagramm dargestellt werden.
Leider habe ich nur sehr wenig Erfahrung mit VBA, so dass ich es momentan gerade mal mit Hilfe geschafft habe die Datein in eine Geamtdatei zu kopieren. Jedoch alle Werte untereinander und nicht nach Datum sortiert.
Hoffentlich kann mir jemand Helfen, denn es ist wirklich sehr Zeitaufwendig soetwas manuell zu machen. Ich bin für jeden Tip dankbar!
Vielen Dank im Voraus!
Andreas
hier ist mein bisheriger Code:
Sub zusammenfuegen()
Dim strDateiname As String
Dim loLetzte1 As Long
Dim loLetzte2 As Long
Dim inLetzte As Integer
Application.ScreenUpdating = False
strDateiname = Dir(ThisWorkbook.Path & "\*.csv")
With ThisWorkbook.Worksheets("Tabelle1")
Do While strDateiname <> ""
If strDateiname <> ThisWorkbook.Name Then
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strDateiname
loLetzte1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
loLetzte2 = ActiveWorkbook.ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
inLetzte = ActiveWorkbook.ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
ActiveWorkbook.ActiveSheet.Range(Cells(3, 1), Cells(loLetzte2, inLetzte)).Copy Destination:=.Cells(loLetzte1 + 1, 1)
ActiveWorkbook.Close True
End If
strDateiname = Dir
Loop
End With
Application.ScreenUpdating = True
End Sub
|