|
Hallo Miteinander,
nun ist es tatsächlich an der Zeit, dass ich meinen ersten Beitrag hier verfasse. Jedoch stehe ich vor einem Problem und kann es einfach nicht lösen.
Ich würde gerne den Inhalt eines Ordners mit CSV-Dateien in Xlsx umwandeln und anschließend das alte Format löschen. Das funktioniert im Prinzip auch alles bereits, jedoch befinden sich alle Einträge in der neuen Datei in Zelle A1 und nicht mehr wie im Original untereinander.
Kann mir jemand dabei behilflich sein? :)
Der Code sieht folgendermaßen aus.
Sub konvert()
On Error GoTo Ende
Dim ePath As String
Dim sPath As String
MsgBox "Zur Ausführung des Makros müssen zwei Eingaben erfolgen:" & vbCrLf & vbCrLf & "1. Den ORDNER mit den .csv-Dateien aus Scopus" & _
vbCrLf & "2. Die Datei aus Scopus" & ActiveSheet.Name, vbOKCancel + vbInformation, "Information"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "C:\Windows\System32\"
.Title = "Ordner auswählen"
If .Show Then ePath = .SelectedItems(1)
End With
Dim sFile As String, iFree As Integer
Dim arrCSV, arrTmp, arrXLS(), i As Long, j As Integer, n As Long
sPath = ePath & "\"
sFile = Dir(sPath & "*.csv")
Application.ScreenUpdating = False
Do While Len(sFile)
iFree = FreeFile
Open sPath & sFile For Input As iFree
arrCSV = Split(Input(LOF(iFree), iFree), vbCrLf)
Close iFree
For i = 0 To UBound(arrCSV)
arrTmp = Split(arrCSV(i), ";")
n = Application.Max(n, UBound(arrTmp))
Next
ReDim arrXLS(1 To UBound(arrCSV) + 1, 1 To n + 1)
For i = 0 To UBound(arrCSV)
arrTmp = Split(arrCSV(i), ";")
For j = 0 To UBound(arrTmp)
arrXLS(i + 1, j + 1) = arrTmp(j)
Next
Next
With Workbooks.Add
.Sheets(1).Cells(1, 1).Resize(UBound(arrXLS), UBound(arrXLS, 2)) = arrXLS
.SaveAs sPath & Left(sFile, Len(sFile) - 4), xlOpenXMLWorkbook
.Close
End With
sFile = Dir
Loop
Kill sPath & "*.csv"
Ende:
End Sub
Vielen Dank für die Unterstützung!
|