27.08.2013

63327

Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen

Hallo liebe Community,

Ich bin neu im Forum und hoffe ihr könnt mir vielleicht helfen

Ich habe einen Ordner, in dem sich mehrere CSV Dateien befinden.
Diese möchte ich per Makro in Ecxel importieren.
Und zwar so, dass sie bei der ausgabe gleich das richtige Zeilen- und Spaltenformat haben.
Der Ordner wird ab und zu aktualisiert, d.h. dieses Makro sollte dann bei Ausführung die jeweils aktuellen Dateien im Ordner in Ecxel importieren und veraltete Dateien, die evtl noch vorhanden sind ersetzen.
Ich habe bereits ein Makro im Internet gefunden, welches alle Dateien auf einmal einliest, allerdings war das Tabellen Layout meiner CSV Dateien dabei verschwunden.
Sie wurden fortlaufend in eine Zeile geschrieben und dieses Problem würde ich sehr gerne umgehen.
Ich würde mich sehr über eure Hilfe freuen

LG Lemon

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

Content-ID: 215316

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

Ausgedruckt am: 16.11.2024 um 17:11 Uhr

43 Kommentare

Neuester Kommentar

Hallo Lemon,
das könntest du z.B. so realisieren:
Das Makro öffnet jede CSV-Datei in einem Ordner, führt die Spaltenerkennung durch und kopiert den Inhalt in ein Worksheet mit dem Namen der CSV-Datei in deine Excel-Datei. Die Optionen für die Texterkennung der CSV-Datei musst du an das Format deiner CSV-Dateien in Zeile 25 des Codes anpassen. Im Beispiel werden Semikolons zur Spaltentrennung verwendet. Den Pfad zu den CSV-Dateien musst du noch in Zeile 2 des Codes anpassen.

Sub ImportiereCSVDateien()
    Const CSVPFAD = "E:\csv-dateien"  
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set wbTarget = ActiveWorkbook
    Application.DisplayAlerts = False
    'Lösche alle Worksheets bevor wir alle neu anlegen  
    If wbTarget.Worksheets.Count > 1 Then
        For i = 1 To wbTarget.Worksheets.Count - 1
            wbTarget.Worksheets(i).Delete
        Next
    End If
    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
    Application.DisplayAlerts = True
    Set fso = Nothing
End Sub

Grüße Uwe

Hallo Uwe,

Vielen Dank für deine schnelle Antwort.

Ich neu was das programmieren und das arbeiten mit Scripts angeht und habe deswegen immernoh ein paar Probleme Fehler in meinen Dateien und Scripts zu erkennen. Ich habe dein Makro gleich ausprobiert und VBA markiert mir gleich die erste Zeile gelb "Sub ImportiereCSVDateien()" und verweist mich auf "Set fso" in der 4. Zeile. Den Pfad der Dateien habe ich schon eingetragen. Weißt du vllt woran das leigen könnte?

LG Lemon

Ich hoffe du hast das Script von dieser Seite nicht inklusive der Zeilennummern in dein VBA Projekt kopiert !! Dazu gibt es den Link "Quelltext" oben rechts des Codes.

Ne Ne^^ nur den reinen Text.

Hast du zufällig Oben im Codefenster Option Explicit stehen ?, dann lösch es mal raus.
Welche Fehlermeldung bringt dein Excel denn dazu?
Habe das Script hier erfolgreich getestet...

Grüße Uwe

Ah super jetzt klappts

Vielen Dank!!!

Ich habe zum Test 3 Dateien im Ordner gehabt.
Er hat mir für jede ein neues Tabellenblatt angelegt.
Kannst du mir vllt noch verraten, wie er zusätzlich noch eins erstellt, in dem alle aufeinmal aufgelistet werden?
Wäre echt klasse

Aber trotzdem schonmal vielen Dank für das tolle Makro

Das macht die ganze Sache erheblich leichter

Gruß Lemon

Zitat von @113139:
Kannst du mir vllt noch verraten, wie er zusätzlich noch eins erstellt, in dem alle aufeinmal aufgelistet werden?
Wäre echt klasse

Sub ImportiereCSVDateien()
    Const CSVPFAD = "E:\csv-dateien"  
    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, DataType:=xlFixedWidth
            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

Viel Spaß

Grüße Uwe

Hallo Uwe,

Alles klappt total super einwandfrei!

Vielen Vielen Dank

Grüße Lemon

gern geschehen!
Bitte den Beitrag noch als gelöst markieren.

Grüße Uwe

Hallo zusammen,

ich bin auch neu hier und bin begeistert, dass ich das gefunden habe, was ich schon lange suche.

Der Import der CSV-Dateien aus einem Ordner in eine Excel Datei klappt sehr gut. Allerdings habe ich noch ein kleines Problem:

aus ursprünglich:
"
Trendlogs

Timestamp Trend__Archive1
30.01.2014 00:07 190,387
30.01.2014 00:22 190,387
30.01.2014 00:37 190,388
30.01.2014 00:52 190,389
30.01.2014 01:07 190,390
.
.
.
.

"

wird folgendes importiert:
"
Trendlogs

Timestamp Trend__Archive1
30.01.2014 00:07:36 190
30.01.2014 00:22:35 190
30.01.2014 00:37:34 190
30.01.2014 00:52:34 190
30.01.2014 01:07:33 190
.
.
.
.

"
Zeilen >10000

Dabei wird die Nachkommastelle des Messwertes abgeschnitten (190,xxx). Durch Umformatierung kann die Nachkommastelle nicht zurückgeholt werden.

Ich hätte da noch ein zweites Anliegen, bei dem ich ohne Hilfe nicht weiter komme:

Ich habe im Grunde ca. 50 solcher Einzel-Dateien in eine Datei zu importieren. Im Idealfall sollten alle Daten allerdings auf ein Tabellenblatt gelangen und nicht jede Datei ein eigenes Tabellenblatt erhalten. Jede von mir zu importierende Datei hat zwei Spalten (1.Spalte mit Datum und Uhrzeit; 2. Spalte mit Messwert) die immer vollständig zu importieren sind.

Ich bin für jeden Tipp/jede Hilfe dankbar!!!
Grüße Markus

Hallo Markus, Willkommen im Forum!
das Problem ist das Excel hier beim Import via Code das englische Zahlenformat benutzt, wenn du bei den Zahlen das Komma durch einen Punkt ersetzt wird es richtig importiert.
Hier aber eine Lösung die das automatisch macht und alle CSV-Daten in ein Sheet untereinander importiert und die Überschriften dabei nicht wiederholt.
Da du oben kein Trennzeichen für die Spalten der CSV-Datei angegeben hast habe ich mal das Semikolon als Trennzeichen genommen (lässt sich in Zeile 19 / zweiter Parameter festlegen). Den Pfad zu den CSV-Dateien legst du in Zeile 3 fest.
Zum starten des Imports muss die Prozedur ImportiereCSVDateien() gestartet werden.

Sub ImportiereCSVDateien()
    Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer
    Const CSVPFAD = "E:\csvdateien"  
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set ws = Worksheets(1)
    ws.Range("A:ZZ").Clear  
    Set startRange = ws.Range("A1")  
    Set curRange = startRange
    Application.DisplayAlerts = False
    counter = 1
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(Right(f.Name, 3)) = "csv" Then  
            Dim importHeader As Boolean
            If counter = 1 Then
                header = True
            Else
                header = False
            End If
            importCSV f.Path, ";", curRange, header  
            Set curRange = curRange.End(xlDown).Offset(1, 0)
            counter = counter + 1
        End If
        
    Next
    ws.ListObjects.Add xlSrcRange, ws.Range(startRange, curRange.Offset(-1, curRange.Offset(-1, 0).End(xlToRight).Column - 1))
    Application.DisplayAlerts = True
    Set fso = Nothing
End Sub

Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
    Dim intStart As Integer
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    patNumber = "^([\d\.,\+\-]+)$"  
    arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)
    Set rngCurrent = targetRange
    If importHeader Then
        intStart = 0
    Else
        intStart = 1
    End If
    For i = intStart To UBound(arrLines)
        If arrLines(i) <> "" Then  
            cols = Split(arrLines(i), delim, -1, vbTextCompare)
            For c = 0 To UBound(cols)
                rngCurrent.Offset(0, c).ClearFormats
                wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare))  
                ' check for Numberformat  
                regex.Pattern = patNumber
                Set matches = regex.Execute(wert)
                If matches.Count > 0 Then
                    wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare)  
                End If
                ' set value in cell  
                rngCurrent.Offset(0, c).Value = wert
            Next
            Set rngCurrent = rngCurrent.Offset(1, 0)
        End If
    Next
    Set fso = Nothing
    Set regex = Nothing
End Function

Grüße Uwe

Hi,
dieses Makro ist echt super! Aber ist es auch möglich, an Stelle die Daten untereinander aufzuführen, diese nebeneinander auf zu listen? Wäre sehr dankbar, wenn jemand mir helfen würde =)

Zitat von @Zebras:

Hi,
dieses Makro ist echt super! Aber ist es auch möglich, an Stelle die Daten untereinander aufzuführen, diese
nebeneinander auf zu listen? Wäre sehr dankbar, wenn jemand mir helfen würde =)

in Teil 2 steht die Lösung für dich parat:
Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen Teil 2

Grüße Uwe

Perfekt. Vielen vielen Dank. Komm mir zwar etwas blöd vor, dass ich das selbst nicht gesehen habe, aber naja... ^^

Hallo Uwe,

vielen Dank für das tolle Skript.

Ich war genau danach auf der Suche und es funktioniert auch super, allerdings habe ich leider noch eine Frage dazu und habe mich dafür nun auch extra in diesem Forum angemeldet.

Die Spalten A, C, F, und evtl. noch B und H müssen beim Import als Text formatiert werden, da diese führende Nullen haben.
Wo muss das Skript hierzu angepasst werden. Ich habe leider noch gar keine Erfahrung mit VBA Skript und benötige hier leider Hilfe.

Vielen Dank im voraus.

Grüße,
Stephy

Hallo Stephy, Willkommen auf Administrator.de!

vielen Dank für das tolle Skript.

keine Ursache

Die Spalten A, C, F, und evtl. noch B und H müssen beim Import als Text formatiert werden, da diese führende Nullen haben.
Wo muss das Skript hierzu angepasst werden. Ich habe leider noch gar keine Erfahrung mit VBA Skript und benötige hier leider Hilfe.

dazu habe ich dir mal die Import-Funktion angepasst, die die gewünschten Spalten der CSV als Text importiert. Tausche die Funktion einfach durch diese aus:
Die Änderungen findest du in Zeile 25-31

Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
    Dim intStart As Integer
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    patNumber = "^([\d\.,\+\-]+)$"  
    arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)
    Set rngCurrent = targetRange
    If importHeader Then
        intStart = 0
    Else
        intStart = 1
    End If
    For i = intStart To UBound(arrLines)
        If arrLines(i) <> "" Then  
            cols = Split(arrLines(i), delim, -1, vbTextCompare)
            For c = 0 To UBound(cols)
                rngCurrent.Offset(0, c).ClearFormats
                wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare))  
                ' check for Numberformat  
                regex.Pattern = patNumber
                Set matches = regex.Execute(wert)
                If matches.Count > 0 Then
                    wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare)  
                End If
               ' Spalten A, B, C, D, F, H als Text importieren  
                If c = 0 Or c = 1 Or c = 2 Or c = 5 Or c = 7 Then
                    rngCurrent.Offset(0, c).NumberFormat = "@"  
                    rngCurrent.Offset(0, c).Value = wert
                Else
                    rngCurrent.Offset(0, c).Value = wert
                End If
            Next
            Set rngCurrent = rngCurrent.Offset(1, 0)
        End If
    Next
    Set fso = Nothing
    Set regex = Nothing
End Function

Grüße Uwe

Hallo Uwe,

vielen Dank für die Aufnahme im Forum und die suuuuuper schnell Antwort.

Ich muss leider nochmals eine Frage zu dem Skript stellen.

Ich verwende das 2. Skript mit der Zusammenfassung am Ende, die mir an sich auch schon reichen würde.

Welche der Zeilen aus diesem Skript muss ich durch die Zeilen 25-31 ersetzten.

Wie muss ich dieses Skript abspeichern, damit ich es als Vorlage immer wieder aufrufen kann. Ich habe das bereits versucht aber dann bringt Excel eine Fehlermeldung, dass das Makro nicht verfügbar ist oder deaktiviert.

Für den Import habe ich mir eine Form in meinem Excel erstellt und das Makro zugewiesen, geht dies auch noch auf einem anderen Weg.

Vielen Dank

Viele Grüße
Stephy

Zitat von @KurinoKi:
Welche der Zeilen aus diesem Skript muss ich durch die Zeilen 25-31 ersetzten.

wenn du das hier meinst Zeile 49.

Wie muss ich dieses Skript abspeichern, damit ich es als Vorlage immer wieder aufrufen kann. Ich habe das bereits versucht aber
dann bringt Excel eine Fehlermeldung, dass das Makro nicht verfügbar ist oder deaktiviert.

Ein Excelsheet mit Makros musst du im *.xlsm Format abspeichern. Wenn das Makro aber global in allen Arbeitsmappen verfügbar sein soll, musst du es als Addin speichern. Dazu gibst du im "Speichern unter" Dialog als Format Excel Addin *.xlam an. Nach dem Abspeichern gehst du in den Excel-Optionen auf AddIns > Button: Gehe zu "Excel-Addins" und fügst dort dein gerade gespeichertes Addin hinzu und aktivierst es mit einem Häkchen.

Grüße Uwe

Ich verwende diesese Skript

Sub ImportiereCSVDateien()
Const CSVPFAD = "E:\csv-dateien"
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

Hallo IT Freunde,

ich habe das Script getestet und es läuft wunderbar. Vielen Dank an den Ersteller

Gibt es die Möglichkeit in eine zusätzliche Zeile, links dem Datensatz den Dateinamen von der verwendeten csv Datei zu schreiben?

Viele Grüße
Günter

Hallo Goki44, Willkommen auf Administrator.de !

Zitat von @Goki44:
ich habe das Script getestet und es läuft wunderbar. Vielen Dank an den Ersteller

Keine Ursache

Gibt es die Möglichkeit in eine zusätzliche Zeile, links dem Datensatz den Dateinamen von der verwendeten csv Datei zu
schreiben?

sicher, guckst du hier:

Sub ImportiereCSVDateien()
    Const CSVPFAD = "E:\csvdateien"  
    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).Name
            '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 "Vorgang beendet!", vbInformation  
    Set fso = Nothing
End Sub

Viel Spaß
Grüße Uwe

Vielen Dank für die schnelle Rückmeldung

Wie kann ich dieses Makro (welches übrigens super funktioniert) so modifizieren, dass es mir aus den geöffneten csv-Dateien bestimmte Bereiche (Zelle B5, C12-C14 und G15-G59) kopiert ohne ein Extrablatt in meiner Arbeitmappe anzulegen und im Datenblatt "Zusammenfassung" einfügt. Dabei sollen die Daten aus der 1. csv-Datein in Zeile 1 kopiert werden, die aus der 2. csv-Datei in Zeile 2 usw. Bis es in dem Ordner keine csv-Dateien mehr gibt, d.h. die Anzahl der csv-Dateien ist variabel. Ich versuche schon seit 4 Tagen mein Glück, aber Excel scheint nicht mit mir arbeiten zu wollen.

@miregalwie
bitte schaue für deine Anfrage in deine "persönlichen Nachrichten".

Hallo Uwe,

das Makro ist wirklich klasse!
Habe es eingebunden und es erfüllt auch schon fast meine Anforderungen.

Mein Problem ist, dass ich lediglich die "Zusammenfassungs"-Tabelle haben möchte und sonst keine einzelnen Tabellenblätter.
Habe es bisher so geregelt, dass ich einfach an den obigen Code herangehängt habe, dass eben wieder die für mich überflüssigen anderen Tabellenblätter gelöscht werden.
Aus Performance Gründen wäre es natürlich besser, wenn die Tabellenblätter zuvor garnicht erst erstellt werden sondern der Inhalt der CSV-Dateien von Anfang an bloß in das "Zusammenfassungs"-Blatt untereinander hinweg kopiert werden.

Kannst du mir da behilflich sein? Bin mittlerweile schon am verzweifeln, da ich es leider selbst nicht hinbekomme.

Grüße

EDIT: Es handelt sich um folgendes Makro:

Sub ImportiereCSVDateien()
    Const CSVPFAD = "E:\csv-dateien"  
    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

Hallo "colinardo",

ich habe leider noch kaum Kontakt mit Visaul Basic und bin über stundenlange Suche auf diesen älteren Thread gestoßen, der meiner Problemlösung am nächsten kommt. Zum Thema an sich gibt es ja mehrere, die aber immer unterschiedliche Zielformatierungen behandeln.

Hab den Code kopiert aber da ich in meinen csv Dateien zwei Zeilen Überschrift habe, funktioniert es nicht.

Aufgrund meines mangelnden Wissens, schaffe ich es nicht mal den Code so umzuschreiben, dass ich meine csv mit zweizeiliger Überschrift in einer Excel Tabellenblatt zusammenfahren kann.

BESCHREIBUNG DES ABLAUFS
Die erste Datei wird mit dem code incl. der beiden Überschriftszeilen korrekt eingelesen.
Ergebnis: Zwei Überschriften, eine dritte Zeile mit Werten
Bei der Zweite csv wird ohne die erste Überschriftszeile in Tabellenzeile 3 eingelesen und überschreibt somit die Werte aus der ersten csv.
Beim einlesen der dritten csv kommt der Fehler "Anwednungs- oder objektdefinierter Fehler"

Könntest du mir da behilflich sein?

Grüße
Michael

Moin!

Erstmal vielen Dank für das Script.

Zur Sache mit den 2 Headerzeilen habe ich folgenden Vorschlag:

If Counter  <= 2 Then
      Header = True
Else 
      Header = False
End If

In der Funktion importCSV muss dann auch der Zeilenstart angepasst werden.

If ImportHeader Then
      intStart = 0
Else
      intStart = 2
End If

Meine Herausforderung ist eine andere.
Ich wollte bei

arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)

folgende Ergänzung machen, um dort meine ANSI Codierte Datei einlesen zu können, bzw zwischen UTF-8 und ANSI wechseln zu können.

arrLines = Split(fso.OpenTextFile(strPatch, 1, ForReading, TristateFalse).ReadAll(), vbNewLine, -1, vbTextCompare)

Leider klappt das nicht.
Entweder bekomme ich, vermutlich, Chinesische Schriftzeichen, oder ich habe im Text komische Zeichen, wo diese nicht hingehören.

Ich lese mehrere csv Dateien ein. Diese müssen zusammengefasst werden ohne doppelte Header und als eine CSV Datei wieder in einem bestimmten Format und mit einem bestimmten Dateinamen abgespeichert werden. Dann benötige ich die Informationen aus der letzten Spalte, die über eine ZählenWenn Funktion ausgewertet werden und in einem anderen Tabellenblatt immer als Zeile 2 eingefügt werden sollen. Die schon vorhandenen sollen dann jeweils nach unten verschoben werden.

Da ich hier nur das 2003er Office habe, bin ich auf die vorhandenen Möglichkeiten beschränkt.

BlackHell

Hallo Uwe,

ich habe das obige Script ausprobiert und es importiert auch die Daten.

Aber dann erscheint "Laufzeitfehler 1004" und die Zeile 20 ist gelb unterlegt.

Gibt es dafür eine Lösung?

Danke schon mal im Voraus, ich bin eher Laie, was Makros angeht.

Gruß

Steffen

Hi Uwe,

habe dein Code mal angewendet.
Habe eine Vorlage mit drei Sheets.
Mein Problem ist das, das ein neues Sheet angelegt wird und es nicht in das Daten Sheet eingefügt wird.
Dazu soll zu jedem CSV File ein eigenes File erzeugt werden zu der Vorlage.

Sub ImportiereCSVDateien()
    Const CSVPFAD = "C:\Z_Test\"  
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set wbTarget = ActiveWorkbook
    Application.DisplayAlerts = False
    'Lösche alle Worksheets bevor wir alle neu anlegen  
    'If wbTarget.Worksheets.Count > 1 Then  
        'For i = 1 To wbTarget.Worksheets.Count - 1  
       '     wbTarget.Worksheets(i).Delete  
      '  Next  
    'End If  
    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
    Application.DisplayAlerts = True
    Set fso = Nothing
End Sub

Hi,
ist ja auch logisch denn der obige Code erstellt für jede CSV Datei ein neues Sheet, der macht nichts anderes...!
Die anderen Varianten, ob untereinander in einem Sheet zusammengefasst oder nebeneinander etc. pp ... Findest du von mir schon hier im Forum bis zum Abwinken :

Grüße Uwe

Ok gut aber wie bekomme ich es hin das in meiner Vorlage das einzelne CSV eingelesen werden kann?

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:\Z_Test\M176"  
        .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

Mit diesem Coden bekomme ich alle in ein Excelfile was auch ok wäre aber anderen Aufbau dann nach sich zieht

Zitat von @interface31:
Ok gut aber wie bekomme ich es hin das in meiner Vorlage das einzelne CSV eingelesen werden kann?

Indem du den "FolderPicker" durch einen msoFileDialogOpen ersetzt und die Schleife durch eine Itteration über die Dialogauswahl ersetzt

Sub ImportCSVFromFiles()
    Dim wsTemp As Worksheet, wsTarget As Worksheet, curCell As Range, CSVFILES As Object, strCSVDelimiter As String
    
    With Application.FileDialog(msoFileDialogOpen)
        .Title = "CSV-Dateien wählen"  
        .ButtonName = "Auswahl..."  
        .InitialView = msoFileDialogViewList
        .Filters.Add "CSV-Dateien", "*.csv", 1  
        .AllowMultiSelect = True
        If .Show = -1 Then
            Set CSVFILES = .SelectedItems
        Else
            Exit Sub
        End If
    End With
    
    
    'Legt das CSV-Trennzeichen für die Dateien fest  
    strCSVDelimiter = ";"  
    
    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 i = 1 To CSVFILES.Count

        'Temporäres Sheet löschen  
        wsTemp.UsedRange.Clear
        'CSV-Daten in Temporäres Sheet importieren  
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CSVFILES.Item(i), 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
        
        'Daten in Zielsheet kopieren  
        wsTemp.UsedRange.Copy curCell
        
        'Ausgabezeile eins nach unten schieben  
        Set curCell = wsTarget.Cells(wsTarget.UsedRange.Rows.Count + 2, 1)
    Next
    'Temporäres Sheet löschen  
    wsTemp.Delete
    'Spalten anpassen  
    wsTarget.Columns.AutoFit
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Vorgang beendet!", vbInformation  
End Sub

Danke klappt soweit.
Bekomme ich das aber auch automatisiert, so dass ich sage öffne die 100 csv files und speichere sie mit der Vorlage neu ab unter den Namen vom Sheet 1 Celle A1?

Öhm willst du mich jetzt veräppeln ?? Die vorherige Variante hat doch schon automatisch alle Files eines Ordners verarbeitet. Machen kann ich alles, aber das ist hier ja kein Wunschkonzert! Wenn du eine individuelle Anpassung brauchst kannst du mich gerne per PM kontaktieren und in mache dir dann ein Angebot dazu.
Wenn du das nicht willst, Code hast du jetzt eigentlich zur Genüge um das auch selbst zu realisieren.

p.s. Das Übernehmen von Fragen ist hier eigentlich nicht gern gesehen.

[OT]

Zitat von @colinardo:

p.s. Das übernehmen von Fragen ist hier eigentlich nicht gern gesehen.

Und es kostet auch meist mehrere Anläufe, bis es zum Übelnehmen von Fragen kommt.

Grüße
Biber

P.S. Aber bevor es hier lauter wird:
Ich denke, es stehen hier jetzt auch für einen Einsteiger genug Ansätze, um die gewünschte Variation in endlicher Zeit und einem Minimum an Koffein oder anderen Drogen ins Ziel zu bringen. Büschen mehr Mut, interface31. Wenn es garnienich klappt, melde dich nochmal. Ansonsten würde ich den TO-losen Beitrag gerne schliessen.

[/OT]

Hallo Colinardo,

ich benutze diese Version deines Codes:

Sub ImportiereCSVDateien()
    Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer
    Const CSVPFAD = "E:\Datenbank"  
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set ws = Worksheets(1)
    ws.Range("A:ZZ").Clear  
    Set startRange = ws.Range("A1")  
    Set curRange = startRange
    Application.DisplayAlerts = False
    counter = 1
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(Right(f.Name, 3)) = "csv" Then  
            Dim importHeader As Boolean
            If counter = 1 Then
                header = True
            Else
                header = False
            End If
            importCSV f.Path, ";", curRange, header  
            Set curRange = curRange.End(xlDown).Offset(1, 0)
            counter = counter + 1
        End If
        
    Next
    ws.ListObjects.Add xlSrcRange, ws.Range(startRange, curRange.Offset(-1, curRange.Offset(-1, 0).End(xlToRight).Column - 1))
    Application.DisplayAlerts = True
    Set fso = Nothing
End Sub

Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
    Dim intStart As Integer
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    patNumber = "^([\d\.,\+\-]+)$"  
    arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)
    Set rngCurrent = targetRange
    If importHeader Then
        intStart = 0
    Else
        intStart = 1
    End If
    For i = intStart To UBound(arrLines)
        If arrLines(i) <> "" Then  
            cols = Split(arrLines(i), delim, -1, vbTextCompare)
            For c = 0 To UBound(cols)
                rngCurrent.Offset(0, c).ClearFormats
                wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare))  
                ' check for Numberformat  
                regex.Pattern = patNumber
                Set matches = regex.Execute(wert)
                If matches.Count > 0 Then
                    wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare)  
                End If
                ' set value in cell  
                rngCurrent.Offset(0, c).Value = wert
            Next
            Set rngCurrent = rngCurrent.Offset(1, 0)
        End If
    Next
    Set fso = Nothing
    Set regex = Nothing
End Function

Die Importierung an sich Funktioniert.

Ich habe hier nur 4 Anliegen.

1) Die Datenbank wird im mom auf "Worksheets(1)" eingelesen, ist es möglich das es immer in den "Tabellenblatt : Datenbank)" eingelesen wird, egal ob es das 2,3,4 Tabellenblatt ist.

2) Datenbank Tabellenname wird als "Tabelle3" eingetragen, ist es möglich diese zu Ändern in "Master_DB".

3) Noch eine Frage, beim Importieren, werden nur die Spalten A:L als Datenbank eingelesen, die restlichen M:AG werden nicht mehr als Datenbank sonder als normale Tabelle.

4) In den Spalten "D:E" sind Datum und Uhrzeit als "UNIX Timestamp" vorhanden, diese sollen beim Importieren in den Format (DD.MM.JJJJ HH:MM) umgewandelt werden.
Was muss im Code geändert werden? Kannst du mir hier helfen?

Hallo und HILFÄ!
ich bin ein absoluter Laie! Das VBA von Colinardo 29.08.2013 um 11:49 Uhr (CSV importieren und eine Zusammenfassungsseite) ist klasse, funktioniert bei mir leider nicht vollständig. In den CSV-Dateien, die ich benutze ist eigentlich alles nach Spalten ordentlich aufgeteilt (keine Trennung nach Semikolon). In Spalte "L" stehen allerdings Beträge (mit Komma). Das VBA befüllt ab dem Komma des Betrages und die Nachkommastellen nicht mehr und auch jede Spalte danach ist leer. Kann mit bitte jemand helfen? Ich brauche dafür bitte das vollständige VBA (Fragmente helfen mir leider nicht)
Danke!!!!!

Hallo colinardo,

ich habe eine .CSV Datei, in der ebenfalls Kommas vorkommen in den Messwerten. Wie kann ich verhindern, dass durch

Set wbSource = ActiveWorkbook

schon an dem Komma die Werte in einzelne Spalten getrennt werden?

20160101_250742;12872,9;780;678;6853;2,81;14;15,1;14,4;14,1;15;15,8

Dies Werte werden dann schon zu:

9;780;678;6853;2

81;14;15

1;14

4;14

1;15;15

Dadurch werden mit

wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True  

meine Messwerte teilweise gelöscht

Zeile 15

Workbooks.OpenText Filename:=f.Path, DataType:=xlFixedWidth

Grüße Uwe

Danke für die schnelle Antwort, allerdings werden die Werte immer noch am Komma getrennt und in einzelne Spalten geschrieben. Ich denke es würde helfen, wenn VBA beim Öffnen der .CSV die Kommas einfach ignoriert.

Geht hier einwandfrei. Hier wird nichts automatisch am Komma getrennt!
Du kannst zwar noch versuchen in der TextToColumns Zeile den Parameter Comma:=false festzulegen, aber das ist der Defaultwert. Zusätzlich kannst du den Parameter für den DecimalSeparator definieren wenn dieser von Standard in den Regionseinstellungen abweicht.
Ansonsten liegt es an der Kodierung deiner Dateien.
Siehe dazu den Origin Parameter
https://msdn.microsoft.com/de-de/library/office/ff837097.aspx

Weiteres bitte nur per PN. Danke!

Und an alle die hier vorbei kommen noch folgender Hinweis
Hier:
Excel Makro um CSV Dateien auszuwerten und gesammelt anzuzeigen.
gibt es mittlerweile aktuelleren Code von mir. Der von oben ist sagen wir es mal so, schon etwas angestaubt.

Weitere Anpassungswünsche dann bitte nur noch per PN. Merci!

Thread von meiner Seite aus geschlossen.

Hallo,
ich benutze auch den Code wie JoSiBa und er funktioniert sehr gut.
Ich habe bisher csv Dateien mit ca. 60 Zeilen eingelesen. Ohne Probleme. Jetzt wollte ich das ganze an csv Dateien mit nur einer Zeile Daten und dem Header probieren (meine Anwendung gibt das so vor).
Jetzt habe ich das Problem, das die erste Zeile richtig übernommen wird und danach die Fehlermeldung "Laufzeitfehler 1004" - "Anwendungs- oder objektdefenierter Fehler" mit der gelben Markierung auf Zeile 20 stehen bleibt.
Gehe ich auf die Variable curRange wird mir "curRange.End(xlDown).Offset(1, 0)= <Anwendungs- oder objektdefenierter Fehler>" angezeigt.

Ich stehe hier ein wenig auf dem Schlauch. Was muß ich ändern, damit diese eine Zeile ohne Header in meinem Tabellenblatt übertragen wird?
Es sind ca. 1440 einzelne csv. Dateien, die eingelesen werden sollen.

Vielen Dank für jeglichen Hinweis.

Grüße aus Bremen,
Kai

gelöst Frage VB for Applications Entwicklung

Heiß diskutiert