Mehrere CSV Dateien aus verschiedenen Ordner einlesen via VBA

Dim fso As Object

Sub ImportCSVtoFolderGroups()
    Dim dic As Object, file As Variant, strFolderBaseName As String, ws As Worksheet, isFirst As Boolean, rngNext As Range, ROOTFOLDER As Variant, lngEncoding As Long, keys As Variant, i As Long
    
    ' Ordner per Dialog wählen  
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Ordner wählen der die Ordner der CSV-Dateien enthält"  
        .AllowMultiSelect = False
        .ButtonName = "Ordner wählen ..."  
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            ROOTFOLDER = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    ' Encoding Abfrage  
    lngEncoding = IIf(MsgBox("Liegen die CSV-Dateien im 'UTF8'-Encoding vor?" & vbNewLine & "(Bei 'Nein' wird ANSI verwendet)", vbYesNo Or vbQuestion, "Encoding der CSV-Dateien festlegen") = vbYes, 65001, 1252)  
    
    ' Screenrefresh der Performance wegen deaktiveren  
    Application.ScreenUpdating = False
    
    ' Objekte erstellen  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set dic = CreateObject("Scripting.Dictionary")  
    
    ' Dateien rekursiv in Dictionary einlesen  
    GetFileGroups fso.GetFolder(ROOTFOLDER), True, dic, "csv"  
    
    'Ordnernamen  
    keys = dic.keys()
    ' Für jeden Ordner im Dictionary  
    For i = 0 To dic.Count - 1
        'Basisname des Ordners extrahieren  
        strFolderBaseName = fso.GetBaseName(keys(i))
        On Error Resume Next
        ' Sheet setzen  
        Set ws = Worksheets(strFolderBaseName)
        ' Sheet existiert noch nicht lege neues an  
        If Err.Number <> 0 Then
            Set ws = Worksheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = strFolderBaseName
            ' Setze Zielbereich für Import  
            Set rngNext = ws.Range("A1")  
            isFirst = True
            Err.Clear
            On Error GoTo 0
        End If
        With ws
            ' Für jede CSV des Ordners  
            For Each file In Split(dic.Item(keys(i)), "|", -1, vbTextCompare)  
                ' Setze Zielbereich für Import auf nächste leere Zeile  
                Set rngNext = .Range("A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row + IIf(isFirst, 0, 1))  
                
                ' Import der CSV-Daten  
                With .QueryTables.Add(Connection:="TEXT;" & file, Destination:=rngNext)  
                    .Name = "import"  
                    .FieldNames = True  'CSV hat Überschriften  
                    .AdjustColumnWidth = True
                    .RefreshPeriod = 0
                    .TextFilePlatform = lngEncoding   'unicode = 65001 / ANSI = 1252  
                    .TextFileStartRow = IIf(isFirst, 1, 2)  'Überspringe die Überschriftenzeile  
                    .TextFileParseType = xlDelimited
                    .TextFileTextQualifier = xlTextQualifierDoubleQuote
                    .TextFileCommaDelimiter = True  'Komma ist der Delimiter  
                    .Refresh BackgroundQuery:=False
                    .Delete
                End With
                isFirst = False
            Next
            'Spaltenbreite anpassen  
            .UsedRange.EntireColumn.AutoFit
            ' Überschriften Fett machen  
            .Range("1:1").Font.Bold = True  
        End With
        
    Next
    ' Screenrefresh wieder aktivieren  
    Application.ScreenUpdating = True
    'Meldung ausgeben  
    MsgBox "Fertig", vbInformation  
    'Cleanup  
    Set fso = Nothing
    Set dic = Nothing
End Sub

'Funktion die Ordner-Gruppen rekursiv in ein Dictionary einliest  
Function GetFileGroups(ByVal fldr As Object, ByVal boolRecurse, ByRef dic As Object, ByVal strExtension As String)
    Dim file As Object, subfolder As Object
    For Each file In fldr.files
        If LCase(fso.GetExtensionName(file.Name)) = LCase(strExtension) And file.Size > 0 Then
            If dic.Exists(fldr.Path) Then
                dic.Item(fldr.Path) = dic.Item(fldr.Path) & "|" & file.Path  
            Else
                dic.Add fldr.Path, file.Path
            End If
        End If
    Next
    If boolRecurse Then
        For Each subfolder In fldr.SubFolders
            GetFileGroups subfolder, True, dic, strExtension
        Next
    End If
End Function

Root
|
|_Ordner 1
|        |_ datei1.csv
|        |_ datei2.csv
|
|_Ordner 2
|        |_ datei3.csv
|        |_ datei4.csv
|
|_Ordner 3
|        |_ datei5.csv
|        |_ datei6.csv

.TextFilePlatform = xlMSDOS