sommer2013
Goto Top

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

Hallo zusammen,

ich bin wie so mancher auch neu hier und habe zu einem Problem von mir hier die fast die perfekte Antwort gefunden:

unter "Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen" hier im Forum vom 27.08.2013 habe ich ein Spitzen VBA-Macro von Uwe alias colinardo gefunden.

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

Allerdings habe ich da noch ein Problem und ein Anliegen, bei dem mir vielleicht einer helfen kann:

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 sind dabei >10000


Bei dem Import über das VBA-Macro wird die wichtige Nachkommastelle des Messwertes abgeschnitten (190,xxx). Durch Umformatierung kann die Nachkommastelle nicht zurückgeholt werden. Wo und wie kann ich das Macro anpassen???

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. Der zu importierenden Inhalt der Dateien sollte jeweils in die nächsten freien Spalten gepackt werden:


Dateiname1Spalte A DatumUhrzeitDateiname1Spalte B MesswertDateiname2Spalte C DatumUhrzeitDateiname2Spalte D MesswertDateiname 3Spalte E DatumUhrzeitDateiname 3Spalte F Messwert...

Weiß da jemand von Euch wie ich das anstellen kann???


Ich bin für jeden Tipp/jede Hilfe dankbar!!!

Grüße Markus

Content-ID: 232282

Url: https://administrator.de/forum/alle-csv-dateien-in-einem-ordner-mit-einem-vba-makro-einlesen-teil-2-232282.html

Ausgedruckt am: 23.12.2024 um 00:12 Uhr

106543
106543 11.03.2014 um 11:07:08 Uhr
Goto Top
Hallo,

@colinardo hat dir bei Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen schon geantwortet face-smile

Grüße
Exze
colinardo
Lösung colinardo 11.03.2014, aktualisiert am 12.03.2014 um 14:01:12 Uhr
Goto Top
Zitat von @106543:
@colinardo hat dir bei Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen schon geantwortet
Danke Dir für deinen Hinweis Exze, hab den Doppel-Thread erst gerade gesehen face-wink

Abweichend vom Code im Parallel-Thread, platziert der folgende Code die CSV-Dateien nebeneinander auf dem Sheet: (weitere Hinweise zum Code findest du in deinem ersten Ursprungs-Kommentar)
Sub ImportiereCSVDateien()
    Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer, fso As Object, f As Object
    Const CSVPFAD = "E:\csv-dateien"  
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set ws = Worksheets(1)
    ws.Range("A:ZZ").Clear  
    Set startRange = ws.Range("A2")  
    Set curRange = startRange
    Application.DisplayAlerts = False

    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(Right(f.Name, 3)) = "csv" Then  
            importCSV f.Path, ";", curRange, True  
            curRange.Offset(-1, 0).Value = f.Name
            curRange.Offset(-1, 0).Font.Bold = True
            Set curRange = curRange.End(xlToRight).Offset(0, 1)
        End If
        
    Next
    Application.DisplayAlerts = True
    Set fso = Nothing
End Sub

Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
    Dim fso As Object, regex As Object, patNumber As String, arrLines As Variant, rngCurrent As Range, intStart As Integer, cols As Variant, c As Integer, wert As String, matches As Object, i 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
sommer2013
sommer2013 11.03.2014 um 11:49:04 Uhr
Goto Top
Ich war leider nicht ganz Präzise bei meiner Beschreibung im 2.Teil (Doppel-Thread):

Zur Auswertung wäre für mich folgende Anordnung der importierten Dateien extrem viel besser:


Trendlogs1 Trendlogs2 Trendlogs S3...
Timestamp Messwert1 Timestamp Messdaten 2 Timestamp...
30.01.2014 00:07 309,712 30.01.2014 00:07 190,387 ...
30.01.2014 00:22 309,719 30.01.2014 00:22 190,387 ...
30.01.2014 00:37 309,726 30.01.2014 00:37 190,387 ...
30.01.2014 00:52 309,733 30.01.2014 00:52 190,387 ...

Wow ich bin immer noch platt über die schnelle Reaktion- Danke schon mal an Uwe und Exzellius

Bei dem Code oben bekomme ich noch eine Fehlermeldung 400.

Grüße Markus
colinardo
colinardo 11.03.2014 aktualisiert um 12:11:08 Uhr
Goto Top
Zur Auswertung wäre für mich folgende Anordnung der importierten Dateien extrem viel besser:
ist oben angepasst mit den Dateinamen
Zitat von @sommer2013:
Bei dem Code oben bekomme ich noch eine Fehlermeldung 400.
Pfad und Trennzeichen, anpassen, siehe anderen Thread ... ansonsten den Code im Debug-Modus schrittweise ausführen ... hier geht es einwandfrei ..

Zur Info: In den CSV-Dateien sollte nur eine Zeile für die Überschrift und die Zeilen für die Werte stehen, sonst nichts, ansonsten muss das Script angepasst werden!

Eventuell hast du oben in deinen Code noch ein Option Explicit stehen, wenn ja, dies mal rauslöschen.
sommer2013
sommer2013 11.03.2014 um 12:19:58 Uhr
Goto Top
Hallo Uwe,

ich habe das ganze in einzelschritten Durchlaufen. Bei einem Abgespeckten Dateiimport bekomme ich nun die Fehlermeldung Anwendungs- oder objektdefinierter Fehler. Im Ergebnis scheint die Programmierung im folgenden Part hängen zu bleiben.
 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

Auf jeden Fall importiert er die erste Datei richtig. Die Spalten und Zeilen der 2. und die folgenden Dateien werden nicht sichtbar importiert. Dort scheint es zu hängen...

Grüße soweit
colinardo
colinardo 11.03.2014 um 12:26:20 Uhr
Goto Top
Hier gehts auch mit mehreren Files ohne Probleme, dann muss es mit einem deiner Files zusammenhängen, poste mal die Header und einige Zeilen der Dateien...
sommer2013
sommer2013 11.03.2014 um 12:38:28 Uhr
Goto Top
Aach wahrscheinlich liegt es an den Kopfzeilen:


Genaue Abfolge der *.csv-Datei aus dem Editor:

Trendlogs Start Datum/Uhrzeit : 30.01.2014 00:00:00 Ende Datum/Uhrzeit : 23.02.2014 23:59:59;
;
Timestamp;Elektrozaehler_Archive
30.01.2014 00:07;190,387
30.01.2014 00:22;190,387
30.01.2014 00:37;190,387
30.01.2014 00:52;190,387
30.01.2014 01:07;190,387
30.01.2014 01:22;190,388
30.01.2014 01:37;190,388
.
.
.

;
;
;
;

oder?
colinardo
colinardo 11.03.2014 aktualisiert um 12:50:17 Uhr
Goto Top
Zitat von @sommer2013:
Aach wahrscheinlich liegt es an den Kopfzeilen:
oder?
JA, hatte ich aber oben bereits geschrieben, ich passe es dir gleich mal an ..
colinardo
Lösung colinardo 11.03.2014 aktualisiert um 13:03:49 Uhr
Goto Top
in diesem Fall, tausche die untere Funktion durch diese aus (ist nur die Startzeile geändert worden):
Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
    Dim fso As Object, regex As Object, patNumber As String, arrLines As Variant, rngCurrent As Range, intStart As Integer, cols As Variant, c As Integer, wert As String, matches As Object, i 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 = 2
    Else
        intStart = 3
    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
und das nächste mal solchen Inhalt bitte mit Tags posten. Danke.
sommer2013
sommer2013 11.03.2014 um 12:58:56 Uhr
Goto Top
Große Weltklasse!!!

Es geht! Tausend Dank!
106543
106543 11.03.2014 um 13:01:49 Uhr
Goto Top
Dann markier das Ganze doch bitte auch als gelöst face-smile
Info hier: Wie kann ich einen Beitrag als gelöst markieren?

Grüße
Exze
jonnny
jonnny 10.05.2015 um 17:34:50 Uhr
Goto Top
Hallo Forum,
hallo Uwe

vielen Dank für dein Skript!
Ich habe gehofft, es selbst hin zu bekommen, schaffe es aber leider nicht...
Zwei Anpassungen würde ich benötigen:
Jeden Wert in der ersten Spalte möchte ich vom UNIX-Zeitformat umrechnen und als Datum formatieren. Nach meinem Empfinden müsste das so funktionieren: wert = (wert + 7200) / 86400 + 25569 Das geht so aber leider nicht.
In die zweite Spalte soll wieder der Wert der ersten Spalte geschrieben werden, diesmal als Uhrzeit formatiert. Alle weiteren Spalten müssen demnach eine Spalte weiter nach rechts verschoben werden.

Vielleicht kann mir dabei jemand helfen?

Sonnige Grüße
Jonny