Jul 14 2022 11:19 AM - edited Jul 14 2022 11:48 AM
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
Jul 14 2022 12:02 PM
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)
Jul 14 2022 12:45 PM
Jul 15 2022 03:08 AM
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
Jul 19 2022 02:30 AM
Jul 19 2022 03:30 AM
I hope that someone else can help you.