Copy Entire Column from Multiple Workbooks through Header Name and Paste Appended Result into Opened

HansVogelaar 

Managed to developed this but still an error.

Sub LoopAllExcelFilesInFolder()
    
    Dim wb          As Workbook
    Dim myPath      As String
    Dim myFile      As String
    Dim myExtension As String
    Dim FldrPicker  As FileDialog
    Dim twb         As Workbook
    Dim LastRow     As Long, colArr As Variant, order As Long, i As Long
    
    Application.ScreenUpdating = FALSE
    Application.EnableEvents = FALSE
    Application.Calculation = xlCalculationManual
    
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    Set twb = ThisWorkbook
    
    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = FALSE
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
    
    NextCode:
    myPath = myPath
    If myPath = "" Then GoTo ResetSettings
    
    myExtension = "*.xlsx*"
    
    myFile = Dir(myPath & myExtension)
    
    Do While myFile <> ""
        Set wb = Workbooks.Open(Filename:=myPath & myFile)
        
        DoEvents
        
        LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = LBound(colArr) To UBound(colArr)
            order = sht.Rows(1).Find("Company Name", LookIn:=xlValues, lookat:=xlWhole).Column
            sht.Range(sht.Cells(2, order), sht.Cells(LastRow, order)).Copy twb.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            
        Next i
        
        wb.Close SaveChanges:=True
        
        DoEvents
        
        myFile = Dir
    Loop
    
    MsgBox "Task Complete!"
    
    ResetSettings:
    Application.EnableEvents = TRUE
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = TRUE
    
End Sub