Looping through folder

[Mike2502]

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

 

[Rijnsent]

Hi Mike,
firstly: could you please use the VBA code wrapper, as that makes your code much more readable? To answer your questions:
Replace Dir(MyDir & "*.xls") by Dir(MyDir & "*.xls*") to include xlsx and xlsm files.
And for the second part of your question, replace the last loop by something like:

Do While MyFile <> ""
    LastRw = Wb.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
    Set Wb2 = Workbooks.Open(MyFile)
    Wb.Worksheets("Sheet1").Range("A" & LastRw + 1).Value = Wb2.Worksheets("Sheet1").Range("A2")
    Wb.Worksheets("Sheet1").Range("B" & LastRw + 1).Value = Wb2.Worksheets("Sheet1").Range("A5")
    Wb.Worksheets("Sheet1").Range("C" & LastRw + 1).Value = Wb2.Worksheets("Sheet1").Range("B5")
    Wb.Worksheets("Sheet1").Range("D" & LastRw + 1).Value = Wb2.Worksheets("Sheet1").Range("D5")
    Wb.Worksheets("Sheet1").Range("E" & LastRw + 1).Value = Wb2.Worksheets("Sheet1").Range("E7")
    Wb2.Close True
    Application.DisplayAlerts = 1
    MyFile = Dir()
Loop

Hope that helps?
Koen