How to modify the macro wich summarize all the files from the particular folder?

Hi!

I've got a macro wich I use for consolidating everyday reports into one - it works great, but I'd like to modify it a bit.

The criteria I'd like to add:

1) I don't need all the content of each seperate file,-
The content must be evaluated by column V5,
consequently if value of column V5>0 then the row must be included in the summary;

2) One more additional column in the summary is needed, which must be filled with the name of each particular file.

The code I've been using till now:

Sub Auto_Open()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer, ws As Worksheet, wt As Worksheet

MyPath = ActiveWorkbook.Path

MyName = ActiveWorkbook.Name: Set ws = Sheets("Summary")

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(MyPath)

Count = 0
Sheets("Summary").Select

For Each objFile In objFolder.Files
If objFile.Name <> MyName Then
Temp = objFile.Name
If objFile.Name Like "*.xls*" Then
MyLR = ws.Range("A65536").End(xlUp).Row + 1
ChDir MyPath
On Error GoTo ExitSub
Workbooks.Open Filename:=Temp: Set wt = ActiveSheet

wt.Range("A2", Cells(Range("A65536").End(xlUp).Row, 26)).Copy ws.Range("A" & MyLR)

Windows(objFile.Name).Close False

End If: End If

Next objFile

ExitSub: End Sub

The files for consolidation attached:Summary-Macros.zip

The expected resul would be: Expected-result.xls

Thanks in advance!

Hi Arty,

Try this:

Sub Auto_Open()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer, ws As Worksheet, wt As Worksheet, R As Range

MyPath = ActiveWorkbook.Path

MyName = ActiveWorkbook.Name: Set ws = Sheets("Summary")

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(MyPath)

Count = 0
Sheets("Summary").Select

For Each objFile In objFolder.Files
If objFile.Name <> MyName Then
Temp = objFile.Name
If objFile.Name Like "*.xls*" Then
MyLR = ws.Range("B" & Rows.Count).End(xlUp).Row + 1
ChDir MyPath
On Error GoTo ExitSub
Workbooks.Open Filename:=Temp: Set wt = ActiveSheet


        i = 1: Do Until wt.Cells(1, i) = "V5": i = i + 1: Loop
Set R = wt.UsedRange.Offset(1): R.AutoFilter Field:=i, Criteria1:=">0"
wt.UsedRange.SpecialCells(xlCellTypeVisible).Offset(1).Copy ws.Range("B" & MyLR)
        i = MyLR: Do Until ws.Cells(i + 1, 2) = "": i = i + 1: Loop
ws.Range("A" & MyLR).Resize(i - MyLR + 1, 1).Value = wt.Parent.Name
        wt.AutoFilterMode = False

Windows(objFile.Name).Close False

End If: End If

Next objFile

ExitSub: End Sub

Hi, xladept! Thanks for yor help!

I was trying to consolidate 5 files, 22000 rows each, consequently 590 rows should be shown as a result in the summary file, but it's just 90 rows,

furthermore the values aren't filtred by the determined criteria ">0"

I did change the column name in the code.

P.S.
The number of the column: 5th (the same as in attached files)

Any thoughts?

Make the red code into whatever the new column name is:

Sub Auto_Open()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer, ws As Worksheet, wt As Worksheet, R As Range

MyPath = ActiveWorkbook.Path

MyName = ActiveWorkbook.Name: Set ws = Sheets("Summary")

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(MyPath)

Count = 0
Sheets("Summary").Select

For Each objFile In objFolder.Files
If objFile.Name <> MyName Then
Temp = objFile.Name
If objFile.Name Like "*.xls*" Then
MyLR = ws.Range("B" & Rows.Count).End(xlUp).Row + 1
ChDir MyPath
On Error GoTo ExitSub
Workbooks.Open Filename:=Temp: Set wt = ActiveSheet


        i = 1: Do Until wt.Cells(1, i) = "V5": i = i + 1: Loop
Set R = wt.UsedRange.Offset(1): R.AutoFilter Field:=i, Criteria1:=">0"
wt.UsedRange.SpecialCells(xlCellTypeVisible).Offset(1).Copy ws.Range("B" & MyLR)
        i = MyLR: Do Until ws.Cells(i + 1, 2) = "": i = i + 1: Loop
ws.Range("A" & MyLR).Resize(i - MyLR + 1, 1).Value = wt.Parent.Name
        wt.AutoFilterMode = False

Windows(objFile.Name).Close False

End If: End If

Next objFile

ExitSub: End Sub

I wrote before, that I changed the column name in the code.

Not working - could the size of the large files I try to consolidate be the reason of the issue?

The size shouldn't matter - can you post new samples and/or your new code??

Here are the other bigger files: 14-02-2015.zip15-02-2015.zip16-02-2015.zip

This is the code I used:

Sub Auto_Open()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer, ws As Worksheet, wt As Worksheet, R As Range

MyPath = ActiveWorkbook.Path

MyName = ActiveWorkbook.Name: Set ws = Sheets("Summary")

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(MyPath)

Count = 0
Sheets("Summary").Select

For Each objFile In objFolder.Files
If objFile.Name <> MyName Then
Temp = objFile.Name
If objFile.Name Like "*.xls*" Then
MyLR = ws.Range("B" & Rows.Count).End(xlUp).Row + 1
ChDir MyPath
On Error GoTo ExitSub
Workbooks.Open Filename:=Temp: Set wt = ActiveSheet


        i = 1: Do Until wt.Cells(1, i) = "RESERVE": i = i + 1: Loop
Set R = wt.UsedRange.Offset(1): R.AutoFilter Field:=i, Criteria1:=">0"
wt.UsedRange.SpecialCells(xlCellTypeVisible).Offset(1).Copy ws.Range("B" & MyLR)
        i = MyLR: Do Until ws.Cells(i + 1, 2) = "": i = i + 1: Loop
ws.Range("A" & MyLR).Resize(i - MyLR + 1, 1).Value = wt.Parent.Name
        wt.AutoFilterMode = False

Windows(objFile.Name).Close False

End If: End If

Next objFile

ExitSub: End Sub

Hi Arty,

Try this:

Sub Auto_Open()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer, ws As Worksheet, wt As Worksheet, R As Range

MyPath = ActiveWorkbook.Path

MyName = ActiveWorkbook.Name: Set ws = Sheets("Summary")

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(MyPath)

Count = 0
Sheets("Summary").Select

For Each objFile In objFolder.Files
If objFile.Name <> MyName Then
Temp = objFile.Name
If objFile.Name Like "*.xls*" Then
MyLR = ws.Range("B" & Rows.Count).End(xlUp).Row
ChDir MyPath
On Error GoTo ExitSub
Application.DisplayAlerts = False
Workbooks.Open Filename:=Temp: Set wt = ActiveSheet


        i = 1: Do Until Trim(wt.Cells(1, i)) = "RESERVE": i = i + 1: Loop
Set R = wt.UsedRange: R.AutoFilter Field:=i, Criteria1:=">0"
wt.UsedRange.SpecialCells(xlCellTypeVisible).Copy
ws.Range("B" & MyLR).PasteSpecial xlPasteAll
        i = MyLR: Do Until ws.Cells(i + 1, 2) = "": i = i + 1: Loop
ws.Range("A" & MyLR).Resize(i - MyLR + 1, 1).Value = wt.Parent.Name
      If MyLR > 2 Then ws.Rows(MyLR).Delete Shift:=xlUp
        wt.AutoFilterMode = False

Windows(objFile.Name).Close False

End If: End If

Next objFile

ExitSub: Application.DisplayAlerts = True: End Sub

Hi xladept!

Now it's better but anyway I'm facing an issue:

I tried to consolidate 4 files, as a result only 589 rows were included in the summary file. In fact 591 rows must be there.

I've sorted the data of every seperate file by column REZERVAS in descending sequence,

it's obvious that every last row of column REZERVAS at value > 0

isn't included in the summary file.

It can be checked by the column A:
The codes which aren't included:
CODE145
CODE305
CODE468

I've attached the files and the summary with the code I've used.


Attachment 377820Attachment 377821Attachment 377823Attachment 377824Attachment 377825

I found my mistake

Sub Auto_Open()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer, ws As Worksheet, wt As Worksheet, R As Range

MyPath = ActiveWorkbook.Path

MyName = ActiveWorkbook.Name: Set ws = Sheets("Summary")

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(MyPath)

Count = 0
Sheets("Summary").Select

For Each objFile In objFolder.Files
If objFile.Name <> MyName Then
Temp = objFile.Name
If objFile.Name Like "*.xls*" Then
MyLR = ws.Range("B" & Rows.Count).End(xlUp).Row
ChDir MyPath
On Error GoTo ExitSub
Application.DisplayAlerts = False
Workbooks.Open Filename:=Temp: Set wt = ActiveSheet


        i = 1: Do Until Trim(wt.Cells(1, i)) = "RESERVE": i = i + 1: Loop
Set R = wt.UsedRange: R.AutoFilter Field:=i, Criteria1:=">0"
            If MyLR > 2 Then MyLR = MyLR + 1
wt.UsedRange.SpecialCells(xlCellTypeVisible).Copy ws.Range("B" & MyLR)
        i = MyLR: Do Until ws.Cells(i + 1, 2) = "": i = i + 1: Loop
ws.Range("A" & MyLR).Resize(i - MyLR + 1, 1).Value = wt.Parent.Name
            If MyLR > 2 Then ws.Rows(MyLR).Delete Shift:=xlUp
        wt.AutoFilterMode = False

Windows(objFile.Name).Close False

End If: End If

Next objFile

ExitSub: ws.Cells(1, 1) = "File Name": Application.DisplayAlerts = True: End Sub

Finally we've got it!

It's brilliant!

It'll save LOTS of time and nerves!

Thanks a lot xladept!

Hi Arty,

You say you're missing two rows but three codes? I couldn't access your attachments so I can't look yet - I'll go over the files from yesterday and examine my code??

BTW - You realize that I'm only writing the first header don't you?

You're welcome and thanks for the rep!

(It was a stupid mistake - aren't they all)