Solved: Consolidation macro

[Sir Babydum GBE]

Hi

Each day I will have an unspecified number of identical spreadsheet logs saved into a specific folder. I have a Master spreadsheet that I want to collect all the data to.

In all the other spreadsheets, the data the agents complete starts on Row 3, each row of data contains info from columns A to I but the number of rows will vary depending on how many calls an agent takes each day. If I need to give a figure, then I would choose 1000 as agents would need to be bionic to do more than that.

So can i get a macro in Master.xls to open all other files in the same folder and copy all the data from the other spreadsheets so that I have one very long list on my master sheet?

Thanks

Sir BD

[rory]

Yes.
Is there a column that will always have data in it? (to determine the last row, not a problem if not)
Also, do you want the data appended each time the macro is run, or do you want to clear the old data first?
Regards,
Rory

[Sir Babydum GBE]

Yes.
Is there a column that will always have data in it? (to determine the last row, not a problem if not)
Also, do you want the data appended each time the macro is run, or do you want to clear the old data first?
Regards,
Rory

There should be, but human error might mean that an agent forgets to fill in his name - otherwise it would be column A.

No each day I will create a new report with all of that day's results, the next day will always be a clean sheet.

Thanks Rory

[Bob Phillips]

BD,

Just use Dir to loop through all files in the specified directory (start with say [vba]myFile = Dir("C:\test\*.xls")[/vba] and use [vba]myFile = Dir[/vba] to get the rest, open the workbooks ( as in myFile), calculate the lastrow [vba]With Activeworkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count).End(xlUp).Row
End With
[/vba]
and append to the existing data.

With dir, myFile will be blank when there are no more.

[Charlize]

Not sure if it's still relevant. But I use this to know the real last filled in row and/or column.[vba] 'sh is dimmed as worksheet
'shrange is dimmed as worksheetrange
'Last used row, last used column when
'using usedrange
Set shrange = sh.Range(Cells(1, 1), _
Cells(sh.UsedRange.Rows.Count, sh.UsedRange.Columns.Count))[/vba]so the [VBA]sh.UsedRange.Rows.Count[/VBA]would find the last row with something in (no matter which column) --- that's what I think at least ---

[rory]

You could use something like this - note there is no check for the data going over 65536 rows though!

[VBA]Sub Consolidation()
Dim wbk As Workbook
Dim wksSource As Worksheet, wksDest As Worksheet
Dim strFile As String, strPath As String
Dim rngLastCell As Range
Dim lngRowCount As Long, lngColumnCount As Long, lngTargRow As Long
Dim varData

' Note: the workbook must be saved before running this macro!!
strPath = ThisWorkbook.Path
If strPath = "" Then
MsgBox "This workbook must be saved in directory first!"
Exit Sub
End If
Application.ScreenUpdating = False
strPath = strPath & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Set wksDest = ActiveSheet
lngTargRow = 2
Do Until strFile = ""
If Not strFile = ThisWorkbook.Name Then
Set wbk = Workbooks.Open(strPath & strFile)
' Assumes only one sheet
Set wksSource = wbk.Worksheets(1)
Set rngLastCell = LastCellInSheet(wksSource)
With wksSource
varData = .Range(.Cells(3, "A"), rngLastCell)
End With
lngRowCount = UBound(varData, 1)
lngColumnCount = UBound(varData, 2)
With wksDest
.Range(.Cells(lngTargRow, 1), .Cells(lngTargRow + lngRowCount - 1, _
lngColumnCount)).Value = varData
End With
lngTargRow = lngTargRow + lngRowCount
wbk.Close False
End If
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Public Function LastCellInSheet(wks As Worksheet) As Range
' Returns the cell at the bottom right corner of the sheet's real used range
Dim lngLastCol As Long, lngLastRow As Long
lngLastCol = 1
lngLastRow = 1
On Error Resume Next
With wks.UsedRange
lngLastCol = .Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
lngLastRow = .Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End With
Set LastCellInSheet = wks.Cells(lngLastRow, lngLastCol)
End Function
[/VBA]

HTH
Rory

[Sir Babydum GBE]

Thanks guys - Rory for being so kindly thorough - and XLD and Charlize for trying to teach me!

Sir BD

[ndendrinos]

I find this post similar to mine and the last question in my post remains.,
Will the code fail in the suggestions given here as it does in mine if there is no sheet tiltled Sheet1 (but rather Sheet2) in one of the WBs ? If yes is there an error handler to address this problem ?
Something like on error go to next ....
Thank you.

http://www.vbaexpress.com/forum/showthread.php?t=13804

[ndendrinos]

I now understand this:
[vba]
' Assumes only one sheet
Set wksSource = wbk.Worksheets(1)
[/vba]
Sorry

[Sir Babydum GBE]

Hmm,

I've noticed that where one or more of the Agent spreadsheets have no data - then the headers are imported by this macro - which I don't want to happen.

I see that the code specifies to start at row 3, and this works fine when there's data there - but it screws up if not and I get the imported header (from row 2) plus one blank row.

What's going wrong?

[rory]

The last cell is returned from the header row and the code copies from A3 to the last cell; in this case that range goes up, not down! Try this tweak:
[VBA]Sub Consolidation()
Dim wbk As Workbook
Dim wksSource As Worksheet, wksDest As Worksheet
Dim strFile As String, strPath As String
Dim rngLastCell As Range
Dim lngRowCount As Long, lngColumnCount As Long, lngTargRow As Long
Dim varData

' Note: the workbook must be saved before running this macro!!
strPath = ThisWorkbook.Path
If strPath = "" Then
MsgBox "This workbook must be saved in directory first!"
Exit Sub
End If
Application.ScreenUpdating = False
strPath = strPath & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Set wksDest = ActiveSheet
lngTargRow = 2
Do Until strFile = ""
If Not strFile = ThisWorkbook.Name Then
Set wbk = Workbooks.Open(strPath & strFile)
' Assumes only one sheet
Set wksSource = wbk.Worksheets(1)
Set rngLastCell = LastCellInSheet(wksSource)
If rngLastCell.Row > 2 Then
With wksSource
varData = .Range(.Cells(3, "A"), rngLastCell)
End With
lngRowCount = UBound(varData, 1)
lngColumnCount = UBound(varData, 2)
With wksDest
.Range(.Cells(lngTargRow, 1), .Cells(lngTargRow + lngRowCount - 1, _
lngColumnCount)).Value = varData
End With
lngTargRow = lngTargRow + lngRowCount
End If
wbk.Close False
End If
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
[/VBA]

HTH
Rory

[Sir Babydum GBE]

The last cell is returned from the header row and the code copies from A3 to the last cell; in this case that range goes up, not down! Try this tweak:

HTH
Rory

That worked perfectly thanks!

[Sir Babydum GBE]

Oh,

Can I put a test in the code? Basically I need the code to make sure that, when it cycles through all the workbooks etracting data, it misses workbooks that have nothing to do with this particular exercise.
So I put input "UseWorkbook" in cell A1 of sheet 1 (the same sheet the data is collected from) of the right workbooks, but How do I get the macro to test A1 of Sheet 1 of all the spreadsheets it opens, and if it doesn't contain "UseWorkbook" then to ignore that workbook?

Thanks

[Charlize]

Try this. But can't you check for a similar namepart in the workbooks you want to process. For example Agent ?[VBA]Do Until strFile = ""
If Not strFile = ThisWorkbook.Name Then
'or maybe use this
'and left(strFile,5) = "Agent"
'if every agent puts agent in filename
Set wbk = Workbooks.Open(strPath & strFile)
' Assumes only one sheet
Set wksSource = wbk.Worksheets(1)
Set rngLastCell = LastCellInSheet(wksSource)
'*** extra check on A1
If rngLastCell.Row > 2 And _
wksSource.Range("A1").Value = "UseWorkbook" Then
With wksSource
varData = .Range(.Cells(3, "A"), rngLastCell)
End With
lngRowCount = UBound(varData, 1)
lngColumnCount = UBound(varData, 2)
With wksDest
.Range(.Cells(lngTargRow, 1), .Cells(lngTargRow + lngRowCount - 1, _
lngColumnCount)).Value = varData
End With
lngTargRow = lngTargRow + lngRowCount
End If
wbk.Close False
End If
strFile = Dir
Loop[/VBA]

[rory]

Try this:
[VBA]Sub Consolidation()
Dim wbk As Workbook
Dim wksSource As Worksheet, wksDest As Worksheet
Dim strFile As String, strPath As String
Dim rngLastCell As Range
Dim lngRowCount As Long, lngColumnCount As Long, lngTargRow As Long
Dim varData

' Note: the workbook must be saved before running this macro!!
strPath = ThisWorkbook.Path
If strPath = "" Then
MsgBox "This workbook must be saved in directory first!"
Exit Sub
End If
Application.ScreenUpdating = False
strPath = strPath & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Set wksDest = ActiveSheet
lngTargRow = 2
Do Until strFile = ""
If Not strFile = ThisWorkbook.Name Then
Set wbk = Workbooks.Open(strPath & strFile)
' Assumes only one sheet
Set wksSource = wbk.Worksheets(1)
If LCase$(wksSource.Cells(1, 1).Value) = "useworkbook" Then
Set rngLastCell = LastCellInSheet(wksSource)
If rngLastCell.Row > 2 Then
With wksSource
varData = .Range(.Cells(3, "A"), rngLastCell)
End With
lngRowCount = UBound(varData, 1)
lngColumnCount = UBound(varData, 2)
With wksDest
.Range(.Cells(lngTargRow, 1), .Cells(lngTargRow + lngRowCount - 1, _
lngColumnCount)).Value = varData
End With
lngTargRow = lngTargRow + lngRowCount
End If
End If
wbk.Close False
End If
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
[/VBA]

Regards,
Rory

[Sir Babydum GBE]

...can't you check for a similar namepart in the workbooks you want to process. For example Agent?

Thanks for your answer Charlize

No can do as the agents have autonomy to rename their workbooks if they want to - so a check on a cell seems the most effective solution given my constraints.

Gonna try your solution now - thanks again

[Charlize]

Do they always use the same headers at the same row ?
So A2, B2, C2 ... have always the same text in it.

[Sir Babydum GBE]

Charlize - ceers for your help!

Rory - that works great now - thanks!

[Sir Babydum GBE]

Hi,

In the section of code below that opens all the workbooks in a folder until there aren't any more... I need it to not ask me whether i want to update the links - and I need it to not update the links.

I would put a DisplayAlerts=False bit in there, except I think the default option is to update links - but that slows things down to much and there are no links on the sheets I'm interested in anyway.

Cheers

BD

[Bob Phillips]

There is an UpdateLinks argument to the Open method, use that with a value of 0.