Option Explicit
Sub copydata()
Dim script As Object
Dim catalogue As Object
Dim textfile As Object
Dim loadedfile As Workbook
Dim actualfile As Workbook
Dim path As String
Dim column_index As Integer
path = InputBox("Please input path")
Application.ScreenUpdating = False
Set actualfile = ActiveWorkbook
Set script = CreateObject("Scripting.FileSystemObject")
Set catalogue = script.GetFolder(path)
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
   For Each textfile In catalogue.Files

      Workbooks.Open textfile
      Set loadedfile = ActiveWorkbook
      loadedfile.Worksheets(1).Range("D1:D15").Copy
      column_index = actualfile.Worksheets(1).Range("A5").CurrentRegion.Columns.Count
      actualfile.Worksheets(1).Range("A5").Offset(0, column_index).PasteSpecial
      loadedfile.Close Savechanges:=False

    Next textfile

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

Sub Main()

    Dim path As String
    path = GetFolder("") & ""

    Debug.Print path
End Sub


' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub Copydata()

    Dim path As String
    path = GetFolder("") & ""

    Dim script As FileSystemObject
    Set script = New FileSystemObject

    Dim catalogue As Folder
    Set catalogue = script.GetFolder(path)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False


    Dim textfile As File
    Dim column_index As Integer
    Dim loadedfile As Workbook

    Dim actualfile As Workbook
    Set actualfile = ActiveWorkbook

    For Each textfile In catalogue.Files

        Workbooks.Open textfile
        Set loadedfile = ActiveWorkbook
        loadedfile.Worksheets(1).Range("D1:D15").Copy
        column_index = actualfile.Worksheets(1).Range("A5").CurrentRegion.Columns.Count
        actualfile.Worksheets(1).Range("A5").Offset(0, column_index).PasteSpecial
        loadedfile.Close Savechanges:=False

    Next textfile

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub

' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub Pull_Data_from_Excel_with_ADODB()

    Dim cnStr As String
    Dim rs As ADODB.Recordset
    Dim query As String

    Dim fileName As String
    fileName = "C:tempfile1.xlsm"

    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & fileName & ";" & _
               "Extended Properties=Excel 12.0"

    query = "SELECT * FROM [Sheet1$D1:D15]"

    Set rs = New ADODB.Recordset
    rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified

    Cells.Clear
    Range("A2").CopyFromRecordset rs
    Dim cell As Range, i As Long
    'headers
    With Range("A1").CurrentRegion
        For i = 0 To rs.Fields.Count - 1
            .Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        .EntireColumn.AutoFit
    End With
End Sub

Option Explicit

Sub Copydata()

    Dim path As String
    ' retrieve the path to the folder with the files to pull data from
    path = GetFolder("") & ""

    Dim script As FileSystemObject
    Set script = New FileSystemObject

    Dim catalogue As Folder
    Set catalogue = script.GetFolder(path)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Dim cnStr As String
    Dim rs As ADODB.Recordset

    Dim query As String
    ' SQL query to pull D1:D15 from Sheet1 in each file
    query = "SELECT * FROM [Sheet1$D1:D15]"

    Dim wbFile As Variant

    ' iterate through the files in the folder user selected
    For Each wbFile In catalogue.Files

        ' upate the connection string with path to each file
        cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & wbFile & ";" & _
               "Extended Properties=Excel 12.0"

        ' populate a recordset with D1:D15 from each file
        Set rs = New ADODB.Recordset
        rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified

        ' Copy data from recordset to range in one go
        Range("A5").Offset(0, Range("A5").CurrentRegion.Columns.Count).CopyFromRecordset rs

        ' close the recordset and free memory
        rs.Close
        Set rs = Nothing
    Next wbFile

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub

' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub copydata()
On Error GoTo ErrHandler

'declarations...

'other code...

CleanExit:
    'this code always executes
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
    Exit Sub

ErrHandler:
    'Display message to the user
    MsgBox "Error " & Err.Number & " : " & Err.Description, vbCritical, "Unexpected Error!"
    Resume CleanExit
End Sub

Option Explicit

Sub copydata()

    Dim path As String
    path = InputBox("Please input path")

    Application.ScreenUpdating = False

    Dim actualfile As Workbook
    Set actualfile = ActiveWorkbook

    Dim script As Object
    Set script = CreateObject("Scripting.FileSystemObject")

    Dim catalogue As Object
    Set catalogue = script.GetFolder(path)

    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Dim textfile As Object
    For Each textfile In catalogue.Files

        Workbooks.Open textfile

        Dim loadedfile As Workbook
        Set loadedfile = ActiveWorkbook

        loadedfile.Worksheets(1).Range("D1:D15").Copy

        Dim column_index As Integer
        column_index = actualfile.Worksheets(1).Range("A5").CurrentRegion.Columns.Count

        actualfile.Worksheets(1).Range("A5").Offset(0, column_index).PasteSpecial
        loadedfile.Close Savechanges:=False

    Next textfile

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub

Private Sub EnableExcelUI(Optional ByVal enabled As Boolean = True)
    Application.ScreenUpdating = enabled
    Application.DisplayAlerts = enabled
    Application.AskToUpdateLinks = enabled
End Sub

'Set xFolder = objFSO.GetFolder(xDir)
'ERROR with Scripting.FileSystemObject
'Run-time Error 76 Path Not Found


Set xFolder = xMainZip.GetFolder(xDir)
'ERROR with Shell.Application
'Run-time Error 438 Object Doesn't support this Property or Method