Howdy,
The code below loops through a folder of files and pastes the range of data however I only want cells A2, A5, B5, D5, E7
Then just to paste the cells above in active worksheet from A2 B2 C2 etc (workbook has Headers)
Also, is there any way to change the extension of the file to xlsm and xls?
Cheers!
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Sheet1")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 2))
Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop
End Sub
The code below loops through a folder of files and pastes the range of data however I only want cells A2, A5, B5, D5, E7
Then just to paste the cells above in active worksheet from A2 B2 C2 etc (workbook has Headers)
Also, is there any way to change the extension of the file to xlsm and xls?
Cheers!
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Sheet1")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 2))
Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop
End Sub