CSV Dateien importieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
ungetestet, sollte aber klappen:


Option Explicit
Public intCalculation As Integer
Sub CSV2XLS()
'Alle .csv (Trennzeichen ;) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer
With Application.FileDialog(4)
.InitialFileName = "n:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
On Error GoTo FEHLER
DoEvents
GetMoreSpeed
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder(strFolder)
iFREE = FreeFile
For Each oFile In oFolder.Files
If oFile.Name Like "*.csv" Then
Set WKS = Worksheets.Add
WKS.Name = oFile.Name
lngL = 1
Open oFile For Input As iFREE
Do Until EOF(iFREE)
Line Input #iFREE, strTxt
myArr = Split(strTxt, ";")
With WKS
.Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
End With
lngL = lngL + 1
Loop
Close #iFREE
End If
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub

Gruß
Rudi

Sub CSV2XLS() 'Alle .csv (Trennzeichen ;) eines Ordners in .xls umwandeln Dim oFS As Object, oFolder As Object, oFile As Object Dim strFolder As String, c As Range Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer With Application.FileDialog(4) .InitialFileName = "n:\" .InitialView = 2 .Title = "Bitte einen Ordner wählen" If .Show = -1 Then strFolder = .SelectedItems(1) Else Exit Sub End If End With On Error GoTo FEHLER DoEvents GetMoreSpeed Set oFS = CreateObject("scripting.filesystemobject") Set oFolder = oFS.getfolder(strFolder) iFREE = FreeFile For Each oFile In oFolder.Files If oFile.Name Like "*.csv" Then Set WKS = Worksheets.Add WKS.Name = Replace(oFile.Name, ".csv", "") lngL = 1 Open oFile For Input As iFREE Do Until EOF(iFREE) Line Input #iFREE, strTxt myArr = Split(strTxt, ";") 'Trennzeichen anpassen With WKS .Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr End With lngL = lngL + 1 Loop Close #iFREE With WKS For Each c In .UsedRange.Columns c.TextToColumns Destination:=c.Cells(1), DataType:=xlDelimited, fieldinfo:=Array(1, _ 1) Next c End With End If Next oFile AUFRAEUMEN: Set oFile = Nothing Set oFolder = Nothing Set oFS = Nothing GetMoreSpeed False Exit Sub FEHLER: If Err.Number Then MsgBox "Fehler!" & vbLf & Err.Description Err.Clear Resume AUFRAEUMEN End If End Sub

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

CSV Dateien importieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread