Forum Discussion
Copy Entire Column from Multiple Workbooks through Header Name and Paste Appended Result into Opened
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 SubDoes 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)- Sir i am still looking for the help.
I hope that someone else can help you.
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- 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
