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

[ShazSh]

I am looking for a code and i have looked around but could not find anything related. Thought to post a question here.

I have multiple workbooks in a Folder around 8 and there are Similar columns in some of these workbooks.

For Example:

There are 6 Workbooks out of 8 have similar column which Header name is "SouthRecord" i want to copy that entire column from multiple workbooks availble in Folder and Paste appended result into an open workbook where from code is being run.

I would appreciate your help.

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

  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
    
      wb.Columns(4).Copy twb.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Offset(, 1)
    
      wb.Close SaveChanges:=True
      
      DoEvents

      myFile = Dir
  Loop

  MsgBox "Task Complete!"

ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

[#2]

@ShazSh

Does it work if you change

      wb.Columns(4).Copy twb.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)

to

      wb.Worksheets(1).Columns(4).Copy twb.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)

[#3]

Actually No.

Because i want to search the Column by Header in each workbook if Header matched then copy entire column and paste into an open workbook then find it in another workbook same goes for all workbook.

Note: All columns will be pasted in Single column.

Because in each workbook the Header is not in Similar column. Their location is different from other workbooks

[#4]

@Hans Vogelaar 

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

[#5]

Sir i am still looking for the help.

[#6]

@ShazSh 

I hope that someone else can help you.