There are multiple Workbooks in a folder and have similar column which Header name is "Name" but in each file column position is chnaged.
I want to search that header in 1st row of each workbook if finds then copy that entire column from multiple workbooks availble in Folder and Paste Unique result (values) into an open workbook where from code is being run.
There is one more thing that i want to extract multiple column by Header please add Array method so i can add more column name. I have attached 3 workbooks and result file
I would appreciate your help.
Sub MultipleSimilarColinto_1() Dim xFd As FileDialog Dim xFdItem As String Dim xFileName As String Dim wbk As Workbook Dim sht As Worksheet Dim twb As Workbook Dim LastRow As Long Dim ws As Worksheet Dim desWS As Worksheet Dim colArr As Variant Dim order As Long Dim i As Long Application.ScreenUpdating = False Application.DisplayAlerts = False ActiveWindow.View = xlNormalView Set xFd = Application.FileDialog(msoFileDialogFolderPicker) Set twb = ActiveWorkbook Set desWS = twb.Sheets("Sheet1") If xFd.Show Then xFdItem = xFd.SelectedItems(1) & Application.PathSeparator Else Beep Exit Sub End If xFileName = Dir(xFdItem & "*.xlsx") Do While xFileName <> "" Set wbk = Workbooks.Open(xFdItem & xFileName) colArr = Array("Name") For Each ws In wbk.Sheets If ws.Name <> "Sheet1" Then LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row For i = LBound(colArr) To UBound(colArr) order = ws.Rows(1).Find("Name", LookIn:=xlValues, lookat:=xlWhole).Column ws.Range(ws.Cells(2, order), ws.Cells(LastRow, order)).Copy desWS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) Next i End If Next ws wbk.Close SaveChanges:=True xFileName = Dir Loop Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub