sunshine89
Oct 13, 2014
view2043
view7
0
Goto Top

CSV-Dateien mit VBA einlesen nach bestimmtem Namen

GermansolvedQuestionVB for ApplicationsDevelopment
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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 251766

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

Printed on: April 23, 2024 at 06:04 o'clock

7 Comments
Latest comment
Goto Top
Mitglied: 114757
Solution 114757 Oct 13, 2014 updated at 12:04:13 (UTC)
Goto Top
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
Member: sunshine89
sunshine89 Oct 13, 2014 at 10:53:14 (UTC)
Goto Top
Vielen Dank für deine schnelle Antwort jodel32.
Haben den Code bei mir jetzt so übernommen, bekomme jedoch die Fehlermeldung "Laufzeitfehler13 Typen unverträglich" face-sad
habe nur den Pfad angepasst und die Start und End-Daten
Mitglied: 114757
Solution 114757 Oct 13, 2014 updated at 12:04:18 (UTC)
Goto Top
hier läufts, hast wahrscheinlich CSV-Dateien in deinem Ordner liegen die nicht deinem angegebenen Format (Datensatz_YYYYMMDD.csv) entsprechen ...
Member: sunshine89
sunshine89 Oct 13, 2014 at 11:40:18 (UTC)
Goto Top
ups habe gerade festgestellt, dass der Dateiname insgesamt 4 mal "_" enthält und erst nach dem vierten das Datum kommt.
Mitglied: 114757
Solution 114757 Oct 13, 2014 updated at 12:04:22 (UTC)
Goto Top
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.
Member: sunshine89
sunshine89 Oct 13, 2014 at 12:03:58 (UTC)
Goto Top
Vielen Vielen Dank jetzt läuft es face-smile
Hab es aber auch so hinbkommen, dass ich einfach "arrBasename(4)" anstatt "arrBasename(1)" gesetzt hab.
Mitglied: 116301
116301 Oct 14, 2014 at 09:09:08 (UTC)
Goto Top
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

Grüße Dieter
GermansolvedQuestionVB for ApplicationsDevelopment
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment