Looping through folder

Mike2502

Board Regular
Joined
Jan 19, 2020
Messages
143
Office Version
  1. 2010
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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

Rijnsent

Well-known Member
Joined
Oct 17, 2005
Messages
1,300
Office Version
  1. 365
Platform
  1. Windows
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:
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,181
Messages
5,640,649
Members
417,159
Latest member
Mayozero

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top