Loop through folder and copy into an existing summary file

[TTDM88]

Hi all,

I've been ou f VBA for while now. 3 days spent trying to get this working and I cant. Your help would be greatly appreciated.

I would like to point to a source folder.
loop through the 13 files.
Copy a set of cells from each file into 1 worksheet in the summary workbook.
Have it fire when I open the summary workbook.
All data is in the same place in all the files.


As a break down.
When I open my summary file.
Code fire
Go to folder XYZ
Open the first file
go to the first tab
Copy cell range B8:G8
paste to worksheet 1 range c3:h3
close file no save
continue to loop pasting in the first free cell under the previous starting c3 ending c15.
save summary
leave it open



After a tonne of searching I've appropriated a couple examples into something that does sometimes works.


Sub jansumtotals()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "Cxxxxxxxxxxxxxx"
.FileType = msoFileTypeExcelWorkbooks
'.Filename = "Book*.xlsm"

If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

'Copy the data
Sheets("Sheet1").Range("B8:G8").Copy
'Activate the destination worksheet
Sheets("Sheet2").Activate
'Select the target range
Range("C3").Select
'Paste in the target destination
ActiveSheet.Paste

Next lCount
End If
End With

On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

 

[Michael M]

Does this work for you ?

Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String, Filename As String, wb As Workbook
Dim sh As Worksheet, ab As Workbook, lr As Long
Set ab = ThisWorkbook
folderPath = "C:\Data\myk\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xls") 'change to suit
Application.DisplayAlerts = False
n = 3
Do While Filename <> ""
    Application.ScreenUpdating = False

    Set wb = Workbooks.Open(folderPath & Filename)

    On Error Resume Next
wb.Sheets("Sheet1").Range("B8:G8").Copy ab.Worksheets("Sheet2").Range("C" & n)
n = n + 1
    Workbooks(Filename).Close
    Filename = Dir
Loop
Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

 

[TTDM88]

Thanks Michael,

I gave it ago. It populated the first line ok but pushed the data 1 cell over. The rest failed.

Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String, Filename As String, wb As Workbook
Dim sh As Worksheet, ab As Workbook, lr As Long
Set ab = ThisWorkbook
folderPath = "C:\Users\jamesse\Desktop\January" 'contains folder path
If Right(folderPath, 1) <> "" Then folderPath = folderPath + ""
Filename = Dir(folderPath & "*.xlsm") 'change to suit
Application.DisplayAlerts = False
n = 3
Do While Filename <> ""
Application.ScreenUpdating = False

Set wb = Workbooks.Open(folderPath & Filename)
On Error Resume Next
wb.Sheets("Summary").Range("B8:G8").Copy ab.Worksheets("January").Range("C" & n)
n = n + 1
Workbooks(Filename).Close
Filename = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Does this work for you ?

Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String, Filename As String, wb As Workbook
Dim sh As Worksheet, ab As Workbook, lr As Long
Set ab = ThisWorkbook
folderPath = "C:\Data\myk\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xls") 'change to suit
Application.DisplayAlerts = False
n = 3
Do While Filename <> ""
    Application.ScreenUpdating = False

    Set wb = Workbooks.Open(folderPath & Filename)

    On Error Resume Next
wb.Sheets("Sheet1").Range("B8:G8").Copy ab.Worksheets("Sheet2").Range("C" & n)
n = n + 1
    Workbooks(Filename).Close
    Filename = Dir
Loop
Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

 

[Michael M]

What do you mean by

It populated the first line ok but pushed the data 1 cell over

When pasted, when copied ??

And this

The rest failed.

Didn't copy ?
Didn't paste ?
Crashed ?

Do you have protected workbooks / worksheets involved ?