CSV-Dateien mit VBA einlesen nach bestimmtem Namen

Hallo,

ich habe in einem Lösungsvorschlag zur Frage "Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen" (27.08.2013) schon den fast perfekten Code zu meinem Problem gefunden. Leider bin ich totaler VBA-Anfänger und muss bei mir aber nicht alle csv-Dateien einlesen, sondern nur diejenigen, welche zwischen zwei Daten liegen die ich vorher festlegen möchte.
Die Datumsangaben finden sich in den Dateinamen wieder zb. "Datensatz_20130820.csv" also 20.08.2013.
Wie könnte ich nun eine Schleife bauen, dass nur die in einem Zeitraum liegenden Daten eingelesen werden?
Ich würde mich riesig über Hilfe freuen

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

Gruß

sunshine89

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

Content-ID: 251766

Url: https://administrator.de/forum/csv-dateien-mit-vba-einlesen-nach-bestimmtem-namen-251766.html

Ausgedruckt am: 23.12.2024 um 08:12 Uhr

7 Kommentare

Neuester Kommentar

Sub ImportiereCSVDateien() 
    On Error Resume Next 
    Const CSVPFAD = "E:\csv-dateien"  
    strStartDate = "01.10.2014"  
    strEndDate = "15.10.2014"  
    '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 fso.GetExtensionName(f.Name) = "csv" Then  
        	strBasename = fso.GetBaseName(f.Name)
    		fDate = CDate(Mid(strBasename,Len(strBasename)-1,2) & "." & Mid(strBasename,Len(strBasename)-3,2) & "." & Mid(strBasename,Len(strBasename)-7,4))  
    	 	If fDate >= CDate(strStartDate) And fDate <= CDate(strEndDate) Then
	            Workbooks.OpenText Filename:=f.Path 
	            Set wbSource = ActiveWorkbook
	            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
        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

Gruß jodel32

Vielen Dank für deine schnelle Antwort jodel32.
Haben den Code bei mir jetzt so übernommen, bekomme jedoch die Fehlermeldung "Laufzeitfehler13 Typen unverträglich"

habe nur den Pfad angepasst und die Start und End-Daten

hier läufts, hast wahrscheinlich CSV-Dateien in deinem Ordner liegen die nicht deinem angegebenen Format (Datensatz_YYYYMMDD.csv) entsprechen ...

ups habe gerade festgestellt, dass der Dateiname insgesamt 4 mal "_" enthält und erst nach dem vierten das Datum kommt.

Zitat von @sunshine89:

ups habe gerade festgestellt, dass der Dateiname insgesamt 4 mal "_" enthält und erst nach dem vierten das Datum
kommt.

OK dann konnte es natürlich nicht laufen, ist oben dahingehend korrigiert, nimmt jetzt an, das das Datum immer am Ende steht.

Vielen Vielen Dank jetzt läuft es

Hab es aber auch so hinbkommen, dass ich einfach "arrBasename(4)" anstatt "arrBasename(1)" gesetzt hab.

Hallo zusammen!

Der Beitrag ist zwar schon gelöst, aber hier noch eine vereinfachte (Direkt-Import)-Variante mit erheblichem Geschwindigkeitsvorteil...

Unter der Annahme, das die Mappe nur ein Sheet (Zusammenfassung) enthält bzw. die Daten in Sheet(1) importiert werden sollen.

Option Explicit

Private Const CsvPath = "E:\Csv-Dateien"  

Private Const DateBeg = "01.10.2014"  
Private Const DateEnd = "15.10.2014"  

Public Sub ImportiereCSVDateien()
    Dim oFso As Object, oFile As Object, oTarget As Range, sDate As String, dDate As Date
    
    Sheets(1).UsedRange.Clear
    Set oTarget = Sheets(1).Range("A1")  
    
    Set oFso = CreateObject("Scripting.FileSystemObject")  
    
    Application.ScreenUpdating = False
    
    For Each oFile In oFso.GetFolder(CsvPath).Files
        If LCase(oFso.GetExtensionName(oFile.Name)) = "csv" Then  
            sDate = Right(oFso.GetBaseName(oFile.Name), 8)
            dDate = CDate(Right(sDate, 2) & "." & Mid(sDate, 5, 2) & "." & Left(sDate, 4))  
        
            If dDate >= CDate(DateBeg) And dDate <= CDate(DateEnd) Then
                Call GetCsvData(oFile.Path, oTarget)
                Set oTarget = oTarget.End(xlDown).Offset(2, 0)
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

Private Sub GetCsvData(ByRef sFileName, ByRef oTarget As Range)
    With Sheets(1).QueryTables.Add(Connection:="Text;" & sFileName, Destination:=oTarget)  
        .AdjustColumnWidth = False
        .TextFileParseType = xlDelimited
        .TextFileSemicolonDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .Refresh BackgroundQuery:=False
        .Delete
    End With
End Sub