Import von csv Dateien

    Application.DisplayAlerts = True
    
    Dim strQuelle As String
    Dim strZiel As String
    Dim objFSO As Object
     
    strQuelle = ""M:\SAGE\kleyling\Export\ResponseWA\*.csv"  
    If Dir(strQuelle) = "" Then MsgBox "Nix da!": Exit Sub  
    strZiel = ""M:\SAGE\kleyling\Export\ResponseWA\Backup\"  
    If Dir(strZiel) = "" Then MkDir (strZiel)  
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    objFSO.MoveFile strQuelle, strZiel
    
    Set objFSO = Nothing
    Set FSO = Nothing

 
Sub ImportiereCSVDateien()
    'Const CSVPFAD = "M:\SAGE\kleyling\Export\ResponseWA"  
    Const CSVPFAD = "D:\CSV-IMP"  
    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
        On Error GoTo 0
        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  
        maxRow = wbTarget.Worksheets(i).Range("A65536").End(xlUp).Row  
        'maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column  
        maxCol = 14
        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
    
    Range("A:C,F:F").NumberFormat = "@"  
    
    Dim strQuelle As String
    Dim strZiel As String
    Dim objFSO As Object
     
    strQuelle = CSVPFAD & "\*.csv"  
    If Dir(strQuelle) = "" Then MsgBox "Nix da!": Exit Sub  
    strZiel = CSVPFAD & "\Backup\"  
    If Dir(strZiel) = "" Then MkDir (strZiel)  
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    objFSO.MoveFile strQuelle, strZiel
    
    Set objFSO = Nothing
    Set FSO = Nothing
 End Sub