CSV importieren, umwandeln, zusammenfassen
08.01.2018 10:00:50
Buchmann
ich komme leider nicht mehr weiter mit einem aktuellen Projekt.
Von Kollegen wurde ich gebeten, ein Makro zu schreiben, dass mehrere CSV Dateien einlesen kann und da dann eine bestimmte Zeile aus jeder CSV Datei in einem Tabellenblatt untereinanderschreibt.
Das habe ich auch hinbekommen. Allerdings musste ich das immer machen, da ich die Verzeichnisse in dem Makro direkt eingetragen hatte und keine andere Idee hatte, wie man das benutzerfreundlich machen kann...
Nun habe ich versucht, das Makro so umzubauen, dass auch ein Benutzer ohne VBA Kenntnisse diese Auswertung verwenden kann. Insbesondere ohne jedes Mal das Makro anpassen zu müssen.
Leider funktioniert es nicht.
Ich habe die CSV Dateien in einem separaten Makro in XLS Dateien umgewandelt und im zweiten Schritt die Zusammenführung der einzelnen XLS Dateien durchgeführt.
Hier das Makro für die Umwandlung:
Sub ConvertCSVtoXLSX2()
Dim strVerzeichnis As String
Dim strZielVerz As String
Dim strDatei As String
Dim strTyp As String
Dim strDateiname As String
Dim varFile As Variant
Dim iSubst, iCounter, iRow, iColumn As Integer
Dim strSourceFile, strTargetFile As String
Dim strBuffer, strFile, strPath, strCreateFile As String
Dim strBufferArray() As String
Dim objFso As Object
Dim FileExists As Boolean
Application.ScreenUpdating = False
strTyp = "*.csv"
strVerzeichnis = "C:\****\****\****\Prozessauswertung CSV Dateien\Test_ANSI\CSV\TEST-CSV\"
strZielVerz = "C:\****\****\****\Prozessauswertung CSV Dateien\Test_ANSI\CSV\TEST-CSV\XLSX\"
strDateiname = Dir(strVerzeichnis & strTyp)
Do Until strDateiname = ""
strSourceFile = strVerzeichnis & strDateiname
strTargetFile = strZielVerz & Split(strDateiname, ".")(0) & ".xls"
Set objFso = CreateObject("Scripting.FileSystemObject")
FileExists = objFso.FileExists(strSourceFile)
If FileExists Then
ActiveWorkbook.ActiveSheet.Cells.Clear
Open strSourceFile For Input As #1
iRow = 0
Do Until EOF(1)
iRow = iRow + 1
Line Input #1, strBuffer
If Application.International(xlDecimalSeparator) = "." Then
strBuffer = Replace(strBuffer, ",", ".")
Else
strBuffer = Replace(strBuffer, ".", ",")
End If
strBufferArray = Split(strBuffer, ";")
For iColumn = LBound(strBufferArray) To UBound(strBufferArray)
If IsNumeric(strBufferArray(iColumn)) Then
ThisWorkbook.Worksheets("Tabelle1").Range("A1").Offset(iRow - 1, iColumn). _
Value = CDbl(strBufferArray(iColumn))
Else
ThisWorkbook.Worksheets("Tabelle1").Range("A1").Offset(iRow - 1, iColumn). _
Value = strBufferArray(iColumn)
End If
Next iColumn
Loop
Close #1
Else
'Falls Datei nicht existiert
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strTargetFile, xlWorkbookDefault
Application.DisplayAlerts = True
strDateiname = Dir
Loop
Application.ScreenUpdating = True
End Sub
Hier der Code für die Zusammenführung der einzelnen XLS-Dateien mit Herausziehen zweier einzelnen Zeilen aus den in XLS umgewandelten CSV-Dateien:
Sub CSV_Import()
Application.ScreenUpdating = False
Dim dateien, i
Dim owkb As Workbook
Dim Bereich As Range
Dim tstring As String
dateien = Application.GetOpenFilename("xls-Dateien (*.xls), *.xls", MultiSelect:=True)
If IsArray(dateien) Then
For i = 1 To UBound(dateien)
Workbooks.Open dateien(i), local:=True
Set owkb = ActiveWorkbook
With ThisWorkbook
'Benötigte Werte Auswählen und kopieren
ActiveSheet.Range("A47:AD47").Copy
Windows("02_****_CSV-Auswertung-Zeile47-48.xlsm").Activate
'Auswählen des Tabellenblatts in das die Werte kopiert werden sollen
Sheets("Zeile47").Select
Cells(i, 1).Select
ActiveSheet.Paste
End With
Application.CutCopyMode = False
owkb.Close False
Next i
End If
If IsArray(dateien) Then
For i = 1 To UBound(dateien)
Workbooks.Open dateien(i), local:=True
Set owkb = ActiveWorkbook
With ThisWorkbook
'Benötigte Werte Auswählen und kopieren
ActiveSheet.Range("A48:AD48").Copy
Windows("02_****_CSV-Auswertung-Zeile47-48.xlsm").Activate
'Auswählen des Tabellenblatts in das die Werte kopiert werden sollen
Sheets("Zeile48").Select
Cells(i, 1).Select
ActiveSheet.Paste
End With
Application.CutCopyMode = False
owkb.Close False
Next i
End If
Application.ScreenUpdating = True
End Sub
Der Versuch, diese beiden Makros zusammenzuführen hat an sich funktioniert. Allerdings habe ich versucht, die Verzeichniss über verschiedene Dialoge zu öffnen und damit weiter zu arbeiten. Allerdings funktioniert es nicht.
Hat jemand hier eine Idee, wie das vernünftig machbar ist?
Vielen Dank schon im Voraus!
Grüße,
Bastian
Anzeige