Consolidation of Data from folders and subfolders using recursion

Option Explicit
Dim wb As Workbook
Dim lr As Long
Dim lrt As Long
Sub GetAllFiles()

    Dim Directory As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select a location containing the files you want to list."
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            Directory = .SelectedItems(1) & "\"
        End If
    End With
 
    Cells.ClearContents
    Call RecursiveDir(Directory)
End Sub

Public Sub RecursiveDir(ByVal CurrDir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim FileName As String
    Dim PathAndName As String
    Dim i As Long
    Dim Filesize As Double

'   Make sure path ends in backslash
    If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"

'   Get files
    On Error Resume Next
    FileName = Dir(CurrDir & "*.*", vbDirectory)
    Do While Len(FileName) <> 0
      If Left(FileName, 1) <> "." Then 'Current dir
        PathAndName = CurrDir & FileName
        If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
          'store found directories
           ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1
        Else
  Set wb = Workbooks.Open(PathAndName)
   lr = ActiveWorkbook.Worksheets("Sheet1").Range("A1048576").End(xlUp).Row
   Range("A2:D" & lr).Copy
   lrt = ThisWorkbook.Worksheets("Sheet1").Range("A1048576").End(xlUp).Row + 1
   ThisWorkbook.Worksheets("Sheet1").Range("A" & lrt).PasteSpecial xlPasteAll
   wb.Close
   End If
    End If
        FileName = Dir()
    Loop
    ' Process the found directories, recursively
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub

ActiveX Data Objects (ADO)

Active X Data Objects (ADO)

Add Below Library to use ADO

Option Explicit

Sub copyfromdb()
Dim salesconn As ADODB.Connection
Dim rst As ADODB.Recordset
Set salesconn = New ADODB.Connection
Set rst = New ADODB.Recordset
salesconn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\sid\Desktop\Movies.accdb;Persist Security Info=False"

salesconn.Open

With rst
.ActiveConnection = salesconn
.Source = "select region from sales"
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With

Worksheets.Add
Range("A1").CopyFromRecordset rst.Fields
Range("A1").CopyFromRecordset rst
rst.Close

salesconn.Close

End Sub

File System Object (FSO)

FSO (File Sytstem Object)

Add Library to use early binding 

Option Explicit

Sub fso()
Dim fso As FileSystemObject
Dim name As String
Dim fldr As String
Dim rng As Range
Dim cell As Range
Dim ts As TextStream
Dim folder As folder
name = Format(Date, "mm-dd-yyyy")
fldr = "C:\Users\pc Admin\Desktop\" & name

Set fso = New FileSystemObject

If Not fso.FolderExists(fldr) Then
Set folder = fso.CreateFolder(fldr)
Else

End If
If Not fso.FileExists(fldr & "\My File.txt") Then
folder.CreateTextFile ("My File.txt")
End If
Set rng = Range("A1").CurrentRegion
Set ts = fso.OpenTextFile(fldr & "\My File.txt", ForWriting)

For Each cell In rng
ts.WriteLine cell
Next

End Sub