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

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 248060

Url: https://administrator.de/contentid/248060

Ausgedruckt am: 16.11.2024 um 21:11 Uhr

6 Kommentare

Neuester Kommentar

Hallo Stephy

du willst nur die spalten A B C F als Text importieren.
Sollen die restlichen Spalten als Standart importiert werden, oder gar nicht importiert werden?
Haben die CSV Dateien jedesmal die gleiche Anzahl Spalten?
Welches Zeichen wird als Feldtrenner im CSV verwendet?

Gruss meierjo

Hallo

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

Hallo,

ja die restlichen Spalten können als Standard importiert werden und die Headline gehen von Spalte A-N und Positionsdeateils von A-J.

Als Trennzeichen wird ein Semikolon verwendet.

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.

Vielen Dank für die Hilfe

Viele Grüße

Stephy

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.

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

Hallo Meuerjo,

ja die restlichen Spalten sollen als Standard importiert werden und die Anzahl der Spalten ist immer identisch und die Dateien unterscheiden sich lediglich in der Zeilenanzahl.
Als Trennzeichen wird Semikolon verwendet.

Vielen Dank

Viele Grüße
Stephy