PDA

View Full Version : Solved: Consolidation macro



Sir Babydum GBE
07-30-2007, 01:56 AM
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
07-30-2007, 03:23 AM
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
07-30-2007, 03:30 AM
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
07-30-2007, 03:36 AM
BD,

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

and append to the existing data.

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

Charlize
07-30-2007, 03:45 AM
Not sure if it's still relevant. But I use this to know the real last filled in row and/or column. '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))so the sh.UsedRange.Rows.Countwould find the last row with something in (no matter which column) --- that's what I think at least ---

rory
07-30-2007, 04:41 AM
You could use something like this - note there is no check for the data going over 65536 rows though!

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


HTH
Rory

Sir Babydum GBE
07-30-2007, 05:20 AM
Thanks guys - Rory for being so kindly thorough - and XLD and Charlize for trying to teach me!

Sir BD

ndendrinos
07-30-2007, 04:50 PM
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
07-30-2007, 11:48 PM
I now understand this:

' Assumes only one sheet
Set wksSource = wbk.Worksheets(1)

Sorry

Sir Babydum GBE
08-01-2007, 07:56 AM
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
08-01-2007, 08:25 AM
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:
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


HTH
Rory

Sir Babydum GBE
08-03-2007, 04:45 AM
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
08-07-2007, 03:37 AM
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
08-07-2007, 04:13 AM
Try this. But can't you check for a similar namepart in the workbooks you want to process. For example Agent ?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

rory
08-07-2007, 04:17 AM
Try this:
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


Regards,
Rory

Sir Babydum GBE
08-07-2007, 04:27 AM
...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
08-07-2007, 04:35 AM
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
08-07-2007, 05:28 AM
Charlize - ceers for your help!

Rory - that works great now - thanks!

Sir Babydum GBE
08-16-2007, 10:08 AM
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
08-16-2007, 10:10 AM
There is an UpdateLinks argument to the Open method, use that with a value of 0.

Sir Babydum GBE
08-16-2007, 10:33 AM
Lovely Jubbley

Cheers Bob

Charlize
08-16-2007, 10:35 AM
Not sure if this will work ActiveWorkbook.UpdateLinks = xlUpdateLinksNever but when you open a workbook, that becomes the active one (lucky guess). Afterwards you could set it back to ActiveWorkbook.UpdateLinks = xlUpdateLinksUserSetting

Sir Babydum GBE
08-17-2007, 02:47 AM
Not sure if this will work ActiveWorkbook.UpdateLinks = xlUpdateLinksNever but when you open a workbook, that becomes the active one (lucky guess). Afterwards you could set it back to ActiveWorkbook.UpdateLinks = xlUpdateLinksUserSetting

Thanks Charlize

I used this: Set wbk = Workbooks.Open(strPath & strFile , UpdateLinks = 0) As Bob suggested and it worked just fine.

Sir Babydum GBE
09-17-2007, 08:24 AM
i put a question here but because this post is marked Solved, I'm gonna do a new post.