Import von csv Dateien
Hallo,
ich verwende bereits folgendes Skript für den Import meiner csv Dateien.
Bei dem Import sollten die Spalten A, B, C, F als Text fomartiert werden.
Die Dateien sollen untereinander eingelesen werden. Eine Datei besteht aus einer Kopfzeile und x Positionszeilen und danach soll in der übernächsten Zeile mit der nächsten Datei die sich im Verzeichnis befindet forgefahren werden.
Können die eingelesenen Dateien danach in ein anders Verzeichnis verschoben werden.
Es können alle Informationen in dem selben Tabellenblatt eingefügt werden. Ich benötige hier keine Trennung.
Herzlichen Dank schon jetzt an alle Helfer
Viele Grüße
Stephy
Sub ImportiereCSVDateien()
Const CSVPFAD = "M:\SAGE\kleyling\Export\ResponseWA"
Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet
Set FSO = CreateObject("Scripting.Filesystemobject")
Set wbTarget = ActiveWorkbook
Application.DisplayAlerts = False
'Lösche alle Worksheets bevor wir alle neu anlegen
While wbTarget.Worksheets.Count > 1
wbTarget.Worksheets(1).Delete
Wend
wbTarget.Worksheets(1).Name = "Zusammenfassung"
wbTarget.Worksheets(1).Range("A:ZZ").Clear
For Each f In FSO.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbSource = ActiveWorkbook
On Error Resume Next
Set ws = wbTarget.Worksheets(f.Name)
If Err <> 0 Then
Set ws = wbTarget.Worksheets.Add
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If
wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbSource.Close False
End If
Next
Set ts = wbTarget.Worksheets("Zusammenfassung")
Dim curCell As Range
Set curCell = ts.Range("A1")
For i = 1 To wbTarget.Worksheets.Count - 1
maxRow = wbTarget.Worksheets(i).Range("A1").End(xlDown).Row
maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column
wbTarget.Worksheets(i).Range(wbTarget.Worksheets(i).Cells(1, 1), wbTarget.Worksheets(i).Cells(maxRow, maxCol)).Copy Destination:=curCell
Set curCell = curCell.End(xlDown).Offset(2, 0)
Next
Application.DisplayAlerts = True
Set FSO = Nothing
End Sub
ich verwende bereits folgendes Skript für den Import meiner csv Dateien.
Bei dem Import sollten die Spalten A, B, C, F als Text fomartiert werden.
Die Dateien sollen untereinander eingelesen werden. Eine Datei besteht aus einer Kopfzeile und x Positionszeilen und danach soll in der übernächsten Zeile mit der nächsten Datei die sich im Verzeichnis befindet forgefahren werden.
Können die eingelesenen Dateien danach in ein anders Verzeichnis verschoben werden.
Es können alle Informationen in dem selben Tabellenblatt eingefügt werden. Ich benötige hier keine Trennung.
Herzlichen Dank schon jetzt an alle Helfer
Viele Grüße
Stephy
Sub ImportiereCSVDateien()
Const CSVPFAD = "M:\SAGE\kleyling\Export\ResponseWA"
Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet
Set FSO = CreateObject("Scripting.Filesystemobject")
Set wbTarget = ActiveWorkbook
Application.DisplayAlerts = False
'Lösche alle Worksheets bevor wir alle neu anlegen
While wbTarget.Worksheets.Count > 1
wbTarget.Worksheets(1).Delete
Wend
wbTarget.Worksheets(1).Name = "Zusammenfassung"
wbTarget.Worksheets(1).Range("A:ZZ").Clear
For Each f In FSO.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbSource = ActiveWorkbook
On Error Resume Next
Set ws = wbTarget.Worksheets(f.Name)
If Err <> 0 Then
Set ws = wbTarget.Worksheets.Add
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If
wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbSource.Close False
End If
Next
Set ts = wbTarget.Worksheets("Zusammenfassung")
Dim curCell As Range
Set curCell = ts.Range("A1")
For i = 1 To wbTarget.Worksheets.Count - 1
maxRow = wbTarget.Worksheets(i).Range("A1").End(xlDown).Row
maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column
wbTarget.Worksheets(i).Range(wbTarget.Worksheets(i).Cells(1, 1), wbTarget.Worksheets(i).Cells(maxRow, maxCol)).Copy Destination:=curCell
Set curCell = curCell.End(xlDown).Offset(2, 0)
Next
Application.DisplayAlerts = True
Set FSO = Nothing
End Sub
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 248060
Url: https://administrator.de/forum/import-von-csv-dateien-248060.html
Ausgedruckt am: 23.12.2024 um 13:12 Uhr
6 Kommentare
Neuester Kommentar
Hallo
Dein Code scheint ja schon alles richtig zu machen, oder??
in deinem Code am ende einfügen, und alle CSV werden in den Ordner Backup verschoben
Gruss
Dein Code scheint ja schon alles richtig zu machen, oder??
Können die eingelesenen Dateien danach in ein anders Verzeichnis verschoben werden.
Application.DisplayAlerts = True
Dim strQuelle As String
Dim strZiel As String
Dim objFSO As Object
strQuelle = ""M:\SAGE\kleyling\Export\ResponseWA\*.csv"
If Dir(strQuelle) = "" Then MsgBox "Nix da!": Exit Sub
strZiel = ""M:\SAGE\kleyling\Export\ResponseWA\Backup\"
If Dir(strZiel) = "" Then MkDir (strZiel)
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle, strZiel
Set objFSO = Nothing
Set FSO = Nothing
in deinem Code am ende einfügen, und alle CSV werden in den Ordner Backup verschoben
Gruss
Das Skript ist toll, das einzige Problem ist, dass bei den Positionen nicht immer alle Spalten in die Zusammenfassung
übernommen werden (I&J) und dass eben die gewünschten Spalten nicht als Text formatiert sind.
übernommen werden (I&J) und dass eben die gewünschten Spalten nicht als Text formatiert sind.
In folgender Code-Zeile springst du nach rechts zur letzten Zelle mit Inhalt
maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column
Wenn nun aber leere Zellen in der Tabelle sind, springt der Cursor nur bis vor die erste Zelle mit Inhalt
Du willst ja aber sowieos nur die Spalten A:N importieren, also kannst du den Code folgendermassen anpassen
maxCol = 14 (N ist der 14. Buchstabe im Alphabet)
Nach dem Import folgende CodeZeile einfügen
Range("A:C,F:F").NumberFormat = "@"
formatiert die Spalten A-C und F im TextFormat
Sub ImportiereCSVDateien()
'Const CSVPFAD = "M:\SAGE\kleyling\Export\ResponseWA"
Const CSVPFAD = "D:\CSV-IMP"
Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet
Set FSO = CreateObject("Scripting.Filesystemobject")
Set wbTarget = ActiveWorkbook
Application.DisplayAlerts = False
'Lösche alle Worksheets bevor wir alle neu anlegen
While wbTarget.Worksheets.Count > 1
wbTarget.Worksheets(1).Delete
Wend
wbTarget.Worksheets(1).Name = "Zusammenfassung"
wbTarget.Worksheets(1).Range("A:ZZ").Clear
For Each f In FSO.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbSource = ActiveWorkbook
On Error Resume Next
Set ws = wbTarget.Worksheets(f.Name)
If Err <> 0 Then
Set ws = wbTarget.Worksheets.Add
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If
On Error GoTo 0
wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbSource.Close False
End If
Next
Set ts = wbTarget.Worksheets("Zusammenfassung")
Dim curCell As Range
Set curCell = ts.Range("A1")
For i = 1 To wbTarget.Worksheets.Count - 1
'maxRow = wbTarget.Worksheets(i).Range("A1").End(xlDown).Row
maxRow = wbTarget.Worksheets(i).Range("A65536").End(xlUp).Row
'maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column
maxCol = 14
wbTarget.Worksheets(i).Range(wbTarget.Worksheets(i).Cells(1, 1), wbTarget.Worksheets(i).Cells(maxRow, maxCol)).Copy Destination:=curCell
Set curCell = curCell.End(xlDown).Offset(2, 0)
Next
Application.DisplayAlerts = True
Range("A:C,F:F").NumberFormat = "@"
Dim strQuelle As String
Dim strZiel As String
Dim objFSO As Object
strQuelle = CSVPFAD & "\*.csv"
If Dir(strQuelle) = "" Then MsgBox "Nix da!": Exit Sub
strZiel = CSVPFAD & "\Backup\"
If Dir(strZiel) = "" Then MkDir (strZiel)
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle, strZiel
Set objFSO = Nothing
Set FSO = Nothing
End Sub
Gruss