PDA

View Full Version : Consolidating multipule workbooks



Northender
09-14-2007, 05:42 AM
Hi,

I am hoping somebody can help me solve the following problem I am having. I am only learning vb at the moment by manipulating what I find to my own problems.footinmout

I need to consolidate a set of reports that are sent every day. I have wrote a macro that moves the files from my inbox to a specific folder. All reports are in one folder and are identical in layout, and will not change. I found the attached thread, but for some reason that I cannot figure it will only open one workbook and then stops. :dunno
http://www.vbaexpress.com/forum/showthread.php?t=14022&highlight=extract+data+from+multipule+workbooks

Ideally I would like this to work without opening the workbooks and also remove any empty rows so that I can format the reports a little nicer.

Any help would be gratefully appreciated.

Bob Phillips
09-14-2007, 06:02 AM
You might as well open them, process then close them. The alternative is to read them using ADIO, which is an overhead and more complex.

Have you ascertained why it stopas after one? Have ypou stepped thrpough the code?

Northender
09-14-2007, 06:42 AM
I have tried to follow the process and it seems to follow ok, but it is as if it doesnt look for / see the next workbook after retreaving the first one. here is the code. Also if I change the statement wbk.Close False to True should that close the workbook that was just opened ? Thanks for help.

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(9, "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
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

Northender
09-14-2007, 08:51 AM
Thankyou for your help, but I seem to have resolved this now, dont know how but I must have had a conflict somewhere...:blush </IMG>

Bob Phillips
09-14-2007, 09:13 AM
So the learning is working :thumb