Excel Makro um CSV Dateien auszuwerten und gesammelt anzuzeigen.

Hallo zusammen,

ich habe hier im Forum ein VBA Script gefunden, welches ich gerne anpassen würde
leider sind meine VBA Kenntnisse nur minimal und hoffe das mir hier einer von euch
helfen kann.

Zunächst wurde ich gerne die CONST "csvpfad" mit der Variable aus der Ordnerauswahl
"strOrnder" füllen, dies ist leider nicht möglich? - Hat hier einer eine Idee?

Des Weiteren würde ich gerne nur Einträge aus den CSV Dateien anzeigen die in der zweiten
Spalte ein "failed" als Wert besitzen. Besteht die Möglichkeit das innerhalb des Makros
so durchzuführen?

Hier das Makro:

Sub ImportiereCSVDateien()

Dim strOrdner As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"  
        .Title = "Ordnerauswahl"  
        .ButtonName = "Auswahl..."  
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strOrdner = .SelectedItems(1)
            If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"  
          Else
            strOrdner = ""  
        End If
    End With

    Const csvpfad = "D:\csv\20141219_007"  
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, curCell As Range
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set wbTarget = ThisWorkbook
    Application.DisplayAlerts = False
    Application.ScreenUpdating = 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(fso.GetExtensionName(f.Name)) = "csv" Then  
            Workbooks.OpenText Filename:=f.Path
            Set wbSource = ActiveWorkbook
            On Error Resume Next
            Set ws = wbTarget.Worksheets.Add(After:=wbTarget.Sheets(wbTarget.Sheets.Count))
            ws.Name = f.Name
            ws.Range("A:ZZ").Clear  
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True  
            wbSource.Worksheets(1).UsedRange.Copy Destination:=ws.Range("A1")  
            wbSource.Close False
        End If
    Next
    
    With wbTarget.Worksheets("Zusammenfassung")  
        Set curCell = .Range("B1")  
        For i = 2 To wbTarget.Worksheets.Count
            'Inhalt der CSV in das Zusammenfassungs-Sheet kopieren  
            wbTarget.Sheets(i).UsedRange.Copy Destination:=curCell
            'Name der Quelle in Spalte A schreiben  
            curCell.Offset(0, -1).Value = wbTarget.Sheets(i).Path
            'Zelle für nächsten Import setzen  
            Set curCell = curCell.Offset(wbTarget.Sheets(i).UsedRange.Rows.Count + 2, 0)
        Next
        'Spaltengröße im Zusammenfassungssheet automatisch anpassen  
        .UsedRange.EntireColumn.AutoFit
        .Select
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Importvorgang erfolgreich durchgeführt.", vbInformation  
    Set fso = Nothing
End Sub

Für eure Hilfe bedanke ich mich schon jetzt.

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

Content-ID: 258309

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

Ausgedruckt am: 16.11.2024 um 15:11 Uhr

13 Kommentare

Neuester Kommentar

Hallo diosinc,
habe dir hier mal ein Demo-Sheet gebaut, der Code vom ursprünglichen Beitrag ist nicht mehr ganz aktuell bzw. nicht mehr Up-to-Date wie man so schön sagt. Der neue ist wesentlich schneller und aufgeräumter:
ImportCSV_258309.xlsm

Sub ImportCSVFromFolder()
    Dim wsTemp As Worksheet, wsTarget As Worksheet, curCell As Range, CSVPFAD As String, fso As Object, f As Object, strCSVDelimiter As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"  
        .Title = "Ordnerauswahl"  
        .ButtonName = "Auswahl..."  
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            CSVPFAD = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    'Legt das CSV-Trennzeichen für die Dateien fest  
    strCSVDelimiter = ";"  
    
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'Zielarbeitsblatt für die importierten Daten  
    Set wsTarget = Worksheets(1)
    wsTarget.Name = "Zusammenfassung"  
    'temporäres Arbeitsblatt für den Import der Daten erstellen  
    Set wsTemp = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    'Inhalt des Zusammenfassungsblattes löschen  
    wsTarget.UsedRange.Clear
    
    'Startausgabezelle festlegen  
    Set curCell = wsTarget.Range("A1")  
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(fso.GetExtensionName(f.Name)) = "csv" Then  
            'Temporäres Sheet löschen  
            wsTemp.UsedRange.Clear
            'CSV-Daten in Temporäres Sheet importieren  
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & f.Path, Destination:=wsTemp.Range("$A$1"))  
                .Name = "import"  
                .FieldNames = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileOtherDelimiter = strCSVDelimiter
                .Refresh BackgroundQuery:=False
                .Delete
            End With
            
            With wsTemp
                'Daten in Zielsheet kopieren  
                .UsedRange.Copy curCell
            End With
            'Ausgabezeile eins nach unten schieben  
            Set curCell = wsTarget.Cells(wsTarget.UsedRange.Rows.Count + 2, 1)
        End If
    Next
    'Temporäres Sheet löschen  
    wsTemp.Delete
    'Spalten anpassen  
    wsTarget.Columns.AutoFit
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Vorgang beendet!", vbInformation  
    Set fso = Nothing
End Sub

Als CSV-Trennzeichen ist im Moment das Semikolon(;) angegeben, das kannst du im Code in Zeile 17 ändern.

Grüße Uwe

Hallo Uwe,

super vielen Dank.

Leider erhalte ich nach der Ordnerauswahl (hier sind 6 CSV Dateien drin) den Fehler "Laufzeitfehler: 7 - Nicht genügend Speicher".
Das hatte mit der altern Version problemlos funktioniert. (Mein Rechner hat 8 GB RAM, daran sollte es auch nicht hängen)

Hast du vielleicht noch eine Idee?

Zusätzlich noch eine Frage: besteht die Möglichkeit den Inhalt der CSV Dateien noch zu Filtern? Also: z.B. wenn das CSV so aussehen würde:

xp0101001;OK;2014-12-19T10:33:16;
xp0101002;FEHLER;2014-12-19T10:33:16;
xp0101003;OK;2014-12-19T10:33:16;

Das in der Excel Ausgabe nur die Einträge mit "FEHLER" angezeigt werden würden?

Vielen Dank

Gruss

Zitat von @diosinc:
Leider erhalte ich nach der Ordnerauswahl (hier sind 6 CSV Dateien drin) den Fehler "Laufzeitfehler: 7 - Nicht genügend
Speicher".

kann ich hier leider nicht nachvollziehen. Der Code funktionierte bisher immer. Denke da hat Excel irgendein Problem mit einer deiner CSV-Dateien. Da müsstest du mir mal deine CSV-Files schicken (melde dich via PM dann schick ich dir meine Mailadresse)

Eventuell haben deine Files ein anderes Zeichenformat, das lässt sich in Zeile 44 festlegen.

Speichere dein Sheet auch noch mal erneut unter anderem Namen ab.

Zusätzlich noch eine Frage: besteht die Möglichkeit den Inhalt der CSV Dateien noch zu Filtern? Also: z.B. wenn das CSV
Das in der Excel Ausgabe nur die Einträge mit "FEHLER" angezeigt werden würden?

lässt sich machen, dazu änderst du folgenden Abschnitt (Zeile 53-56 des obigen Codes) so ab.

With wsTemp
     'Daten nach dem Wort "FEHLER" in der zweiten SPALTE der CSV filtern und in Zielsheet kopieren  
     .UsedRange.AutoFilter
     .UsedRange.AutoFilter Field:=2, Criteria1:="FEHLER"  
     .UsedRange.SpecialCells(xlCellTypeVisible).Copy curCell
End With

In diesem Fall setze ich Überschriften in jeder CSV-Datei voraus, andernfalls müssen noch zusätzlich Kleinigkeiten angepasst werden.

Mit diesem Code werden deine Daten jeweils einmal nach FAILED und OK in der zweiten Spalte gefiltert und dann in zwei unterschiedliche Sheets kopiert. (Deine CSV-Dateien haben keine Übeschriften, das wurde berücksichtigt)

Sub ImportCSVFromFolder()
    Dim wsTemp As Worksheet, wsOK As Worksheet, wsFailed As Worksheet, curCell As Range, CSVPFAD As String, fso As Object, f As Object, strCSVDelimiter As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"  
        .Title = "Ordnerauswahl"  
        .ButtonName = "Auswahl..."  
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            CSVPFAD = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    'Legt das CSV-Trennzeichen für die Dateien fest  
    strCSVDelimiter = ";"  
    
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'Zielarbeitsblätter (OK/FAILED) vorbereiten  
    For Each ws In Worksheets
        If ws.Name = "OK" Then Set wsOK = ws  
        If ws.Name = "FAILED" Then Set wsFailed = ws  
    Next
    If wsOK Is Nothing Then
        Set wsOK = Worksheets.Add
        wsOK.Name = "OK"  
    End If
    If wsFailed Is Nothing Then
        Set wsFailed = Worksheets.Add
        wsFailed.Name = "FAILED"  
    End If
    
    'temporäres Arbeitsblatt für den Import der Daten erstellen  
    Set wsTemp = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(fso.GetExtensionName(f.Name)) = "csv" Then  
            With wsTemp
                'AutoFilter deaktivieren  
                .AutoFilterMode = False
                'Temporäres Sheet löschen  
                .UsedRange.Clear
                'Dummyüberschrift für den Filter  
                .Range("A1").Value = "Dummyüberschrift"  
                'CSV-Daten in Temporäres Sheet importieren  
                With .QueryTables.Add(Connection:="TEXT;" & f.Path, Destination:=.Range("$A$2"))  
                    .Name = "import"  
                    .FieldNames = False
                    .AdjustColumnWidth = True
                    .RefreshPeriod = 0
                    .TextFilePlatform = 1252
                    .TextFileStartRow = 1
                    .TextFileParseType = xlDelimited
                    .TextFileTextQualifier = xlTextQualifierNone
                    .TextFileOtherDelimiter = strCSVDelimiter
                    .Refresh BackgroundQuery:=False
                    .Delete
                End With
                
                'Daten nach dem Wort "FAILED" in der zweiten SPALTE der CSV filtern und in Zielsheet "FAILED" kopieren  
                .UsedRange.AutoFilter
                .UsedRange.AutoFilter Field:=2, Criteria1:="FAILED"  
                .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsFailed.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                
                'Daten nach dem Wort "OK" in der zweiten SPALTE der CSV filtern und in Zielsheet "OK" kopieren  
                .UsedRange.AutoFilter Field:=2, Criteria1:="OK"  
                .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsOK.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            End With
        End If
    Next
    'Temporäres Sheet löschen  
    wsTemp.Delete
    'Spalten anpassen  
    wsOK.Columns.AutoFit
    wsFailed.Columns.AutoFit
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Vorgang beendet!", vbInformation  
    Set fso = Nothing
End Sub

Wenns das dann war, den Beitrag bitte noch auf gelöst setzen. Merci.

Das liest sich alles schon sehr nach dem, was ich suche, nur bekomme ich es nicht selber angepasst:
Ich möchte alle txt Dateien aus einem Ordner in eine Excel Tabelle nebeneinander einfügen. Dabei reicht mir eine Registerkarte aus.
In den txt Dateien liegen steht pro Zeile eine Zahl mit einem Komma als Dezimaltrennzeichen.
Falls das mit txt dateien nicht möglich ist, wäre es auch möglich diese txt Dateien als csv zu speichern

Hallo Uwe,

besteht die Möglichkeit hier auch in der ersten Spalte den Dateinamen einzufügen, sodass jede Zeile aus der csv einen Verweis auf den Dateinamen hat?

In der csv, welche ich nutze, sind nur 5 bis 10 Zeilen drin. Meistens ist die 1. und 2. Zeile sowie die 4. und 5. Zeile gefüllt.

Danke dir schon einmal für den hier bereits zur Verfügung gestellten Code!

Gruß Jens

Servus Jens,
kein Problem, hier für den ersten geposteten Code, kleine Anpassung:
Wenn du's vergleichst siehst du die angepassten Stellen und kannst es auch für die anderen Codes verwenden.

Sub ImportCSVFromFolder()
    Dim wsTemp As Worksheet, wsTarget As Worksheet, curCell As Range, CSVPFAD As String, fso As Object, f As Object, strCSVDelimiter As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"  
        .Title = "Ordnerauswahl"  
        .ButtonName = "Auswahl..."  
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            CSVPFAD = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    'Legt das CSV-Trennzeichen für die Dateien fest  
    strCSVDelimiter = ";"  
    
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'Zielarbeitsblatt für die importierten Daten  
    Set wsTarget = Worksheets(1)
    wsTarget.Name = "Zusammenfassung"  
    'temporäres Arbeitsblatt für den Import der Daten erstellen  
    Set wsTemp = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    'Inhalt des Zusammenfassungsblattes löschen  
    wsTarget.UsedRange.Clear
    
    'Startausgabezelle festlegen  
    Set curCell = wsTarget.Range("B1")  
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(fso.GetExtensionName(f.Name)) = "csv" Then  
            'Temporäres Sheet löschen  
            wsTemp.UsedRange.Clear
            'CSV-Daten in Temporäres Sheet importieren  
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & f.Path, Destination:=wsTemp.Range("$A$1"))  
                .Name = "import"  
                .FieldNames = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileOtherDelimiter = strCSVDelimiter
                .Refresh BackgroundQuery:=False
                .Delete
            End With
            
            With wsTemp
                'Daten in Zielsheet kopieren  
                .UsedRange.Copy curCell
                ' Dateinamen in erste Spalte vor die Zeilen schreiben  
                curCell.Offset(1, -1).Resize(.UsedRange.Rows.Count - 1, 1).Value = f.Name
            End With
            'Ausgabezeile eins nach unten schieben  
            Set curCell = wsTarget.Cells(wsTarget.UsedRange.Rows.Count + 2, 2)
        End If
    Next
    'Temporäres Sheet löschen  
    wsTemp.Delete
    'Spalten anpassen  
    wsTarget.Columns.AutoFit
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Vorgang beendet!", vbInformation  
    Set fso = Nothing
End Sub

Grüße Uwe

Guten Morgen Uwe,

vielen Dank! Ich hatte 2 Zeilen bereits selbst angepasst, aber die 3. (neue Zeile) habe ich einfach nicht allein hinbekommen.
Klappt super und ich lerne immer wieder aus dem Forum.

Viele Grüße

Jens

Hallo zusammen,

ich habe ein ähnliches Problem und bin in VBA ach nicht so fit daher würde ich Hilfe benötigen.

Folgendes ich habe eine csv Datei de wie folgt aussieht
A000;2022.04.25;11:24:06;101;A1234;0001;32,000;000020000002
A000;2022.04.25;11:34:15;101;A5252;0001;56,000;000020000003
A000;2022.04.25;11:52:28;101;AA999;0001;120,000;000020000000
A000;2022.04.25;12:20:37;101;A1234;0001;32,000;000020000002
A000;2022.04.25;13:38:23;101;AA999;0001;47,000;000020000003

Hier möchte ich aber nur werte in die Excel automatisch beim Öffnen der Excel importieren, die im zweiten Abschnitt mit dem jeweils gewünschte Jahr haben (Jahreswert kommt dann aus einer bestimmten Zelle auf einem anderen tabellenblatt) Perfekt wäre es dann noch, wenn aus dem Abschnitt 5 auch nur Werte übernehmen könnte, die in einem extra Tabellenblatt stehen z. B. nur A5252 und AA999.

Ist das so möglich?

Schnmal danke für die Hilfe

Servus @Frogel,
kann man, VBA gerne als Auftrag (PN). Würde es aber gleich mit Powershell umsetzen geht wesentlich fixer

# Jahr
$year = 2022
# Werte der zu inkludierende Zeilen für Spalte 5
$include = 'A5252','AA999'  
# Ordner mit CSV-Dateien
$folder = 'D:\Daten'  
# Neue CSV mit den gefilterten Daten
$exportfile = 'D:\export.csv'  
# Daten filtern und exportieren
Get-Content "$folder\*.csv" | ConvertFrom-CSV -Delimiter ";" -Header (1..8) | ?{$_.2 -like "$year.*" -and $_.5 -in $include } | ConvertTo-CSV -Delimiter ";" -NoTypeInformation | select -skip 1 | out-file $exportfile  

Grüße Uwe

Hallo zusammen,

leider habe ich keinerlei Erfahrungen im schreiben von Makros und benötige daher Eure Hilfe.

Im Grunde benötige ich nur eine Erweiterung des oberen Makros von Uwe. Dieses ist ja so aufgebaut, dass der komplette Text der CSV-Datei untereinander geschrieben wird.

Mein Problem ist, dass ich nur die Daten aus den Zellen A17:A27 benötige und diese sollten dann jeweils auf das Arbeitsblatt "Zusammenfassung" in eine Zeile geschrieben werden, wobei in der ersten Spalte immer der Titel stehen sollte (von vertikal auf horizontal transformieren).

Ich habe es bisher vergebens u.a. mit dem Befehl Range (A17:27) Copy curCell versucht, aber nichts funktionierte so wie wir es gerne hätten.

Ich wäre für eine Lösung sehr dankbar.

Gruß Rudi

Zitat von @mrtamburineman:
Mein Problem ist, dass ich nur die Daten aus den Zellen A17:A27 benötige und diese sollten dann jeweils auf das Arbeitsblatt "Zusammenfassung" in eine Zeile geschrieben werden, wobei in der ersten Spalte immer der Titel stehen sollte (von vertikal auf horizontal transformieren).

Servus Rudi,
willkommen auf Administrator.de!

Hier meine Interpretation deiner Schilderung:

Sub ImportCSVFromFolder()
    Dim wsTemp As Worksheet, wsTarget As Worksheet, curCell As Range, CSVPFAD As String, fso As Object, f As Object, strCSVDelimiter As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"  
        .Title = "Ordnerauswahl"  
        .ButtonName = "Auswahl..."  
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            CSVPFAD = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    'Legt das CSV-Trennzeichen für die Dateien fest  
    strCSVDelimiter = ";"  
    
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'Zielarbeitsblatt für die importierten Daten  
    Set wsTarget = Worksheets(1)
    wsTarget.Name = "Zusammenfassung"  
    'temporäres Arbeitsblatt für den Import der Daten erstellen  
    Set wsTemp = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    'Inhalt des Zusammenfassungsblattes löschen  
    wsTarget.UsedRange.Clear
    
    'Startausgabezelle festlegen  
    Set curCell = wsTarget.Range("A1")  
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(fso.GetExtensionName(f.Name)) = "csv" Then  
            'Temporäres Sheet löschen  
            wsTemp.UsedRange.Clear
            'CSV-Daten in Temporäres Sheet importieren  
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & f.Path, Destination:=wsTemp.Range("$A$1"))  
                .Name = "import"  
                .FieldNames = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileOtherDelimiter = strCSVDelimiter
                .Refresh BackgroundQuery:=False
                .Delete
            End With
            
            With wsTemp
                ' Dateinamen in erste Spalte vor die Daten schreiben  
                curCell.Value = f.Name
                'Daten aus A17:A27 transponiert in Zielsheet kopieren  
                .Range("A17:A27").Copy  
                curCell.Offset(0, 1).PasteSpecial Transpose:=True
            End With
            'Ausgabezeile eins nach unten schieben  
            Set curCell = wsTarget.Cells(wsTarget.UsedRange.Rows.Count + 1, 1)
        End If
    Next
    'Temporäres Sheet löschen  
    wsTemp.Delete
    'Spalten anpassen  
    wsTarget.Columns.AutoFit
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Vorgang beendet!", vbInformation  
    Set fso = Nothing
End Sub

Grüße Uwe