Option Explicit

Sub myCheck_in_One()
    Dim fso         As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim dic         As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim curFold As Object, subFold As Object
    Dim arr As Variant, brr As Variant
    Dim yb As Long, xb As Long, ya As Long, xa As Long
    Dim Application_Calculation As XlCalculation

    Application.ScreenUpdating = False
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    If fso.FolderExists(ThisWorkbook.Path) Then Set curFold = fso.GetFolder(ThisWorkbook.Path)
    If curFold Is Nothing Then Exit Sub

    Dim sFile       As String: sFile = ThisWorkbook.Path & "\check-list.xlsx"

    If fso.FileExists(sFile) Then
        Dim folder_name As String: folder_name = curFold.Name
        Application.StatusBar = folder_name

        Dim sConnString As String: sConnString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & sFile & ";" & _
                "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"

        Dim conn    As Object: Set conn = CreateObject("ADODB.Connection")
        conn.Open sConnString

        Dim rs      As Object: Set rs = CreateObject("ADODB.Recordset")

        ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Dim query   As String: query = "SELECT * FROM [Лист1$C1:C17]"   ' Возможно у вас будет задано другое имя рабочего листа _
                                                                        в этой строке "[Лист1$C1:C17]", измените имя рабочего листа если есть необходимость
        ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        rs.Open query, conn, 3, 1

        Dim arrData As Variant: arrData = rs.GetRows
        rs.Close
        conn.Close

        Set rs = Nothing
        Set conn = Nothing

        arr = Application.Transpose(arrData)
        arr(1, 1) = folder_name

        ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))

        For yb = 1 To UBound(brr, 1)

            For xb = 1 To UBound(brr, 2)
                brr(yb, xb) = arr(xb, yb)
            Next xb

        Next yb

        arr = brr
        dic(dic.Count) = arr

        Application.StatusBar = False
        DoEvents
    End If

    For Each subFold In curFold.SubFolders

        If fso.FolderExists(CStr(subFold)) Then
            CheckFolder CStr(subFold), fso, dic, folder_name
        End If

    Next subFold

    If dic.Count = 0 Then Exit Sub

    brr = dic.Items()
    ReDim arr(1 To dic.Count, 1 To UBound(brr(0), 2))

    For ya = 1 To UBound(arr, 1)

        For xa = 1 To UBound(arr, 2)
            arr(ya, xa) = brr(ya - 1)(1, xa)
        Next xa

    Next ya

    Set dic = Nothing

    Dim wb          As Workbook: Set wb = Workbooks.Add

    With wb.Sheets(1).Range("B6").Resize(UBound(arr, 1), UBound(arr, 2))
        .Value = arr

        '        ' На ваш выбор, Автоматически регулировать ширину столбцов
        '        .Columns.AutoFit
        .Select
    End With

    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub