Consolidating data from multiple workbooks grouped by first column

[LucasLondon]

Hi all,

I have the following code that consolidates data from individual sheets from a workbook into a summary sheet. In each sheet, column A contains a daily date field and column B contains the values associated for those dates, the data is consolidated in the summary sheet by date field placed in the first column of the summary sheet.

VBA:

Option Explicit
Sub Consolidate()
Dim tgt As Range, Source As Range, CkRange As Range, Cel As Range
Dim Rw As Long, i As Long, Dt As Range
Dim c As Range
Application.ScreenUpdating = False
'Loop through each sheet after first
For i = 2 To Sheets.Count
'Find place to post result
Set tgt = Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1)
Sheets(i).Activate
'Find data to copy and copy to target
Set Source = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
Rw = Source.Rows.Count
Source.Copy tgt
'Insert - at any blank cells
Set CkRange = tgt.Offset(, 1).Resize(Rw)
For Each Cel In CkRange
If Len(Cel) = 0 Then Cel = "-"
Next
'Move data to corresponding column
CkRange.Cut tgt.Offset(, i - 1)
Next
Sheets("Summary").Activate

Now, instead of consolidating the data from individual sheets as per above, I would like to change the macro so that it consolidates data from multiple workbooks that I would have opened rather than worksheets from the same workbook.

Each workbook contains data in the first two columns of the first sheet:

The set up of my files looks like this:

Workbook 1 - sheet 1

Col A Col B
11/11/2006 4
12/11/2006 5
13/11/2006 6

Workbook 2 –sheet 1
Col A Col B
11/11/2006 19
13/11/2006 20


Summary Workbook – Sheet 1 (effectively one that I would create that would store the consolidated data)

I'm assuming this is relatively easy change to make to the code, but not sure how, any help would be much appreciated.

Thanks,

Lucas

[gnod]

this is the code i use for consolidation.. maybe it will give you an idea..


Option Explicit
Option Base 1

Const strMdbFilename As String = "Consol - Expense.mdb"

Const strMdbTbl_Exp As String = "tblExp"
Const strMdbTbl_DepreciationExisting As String = "tblDepreciationExisting"
Const strMdbTbl_DepreciationNew As String = "tblDepreciationNew"
Const strMdbTbl_Capex As String = "tblCapex"
Const strMdbTbl_Organic As String = "tblOrganic"
Const strMdbTbl_Subcon As String = "tblSubcon"

Const strMdbQry_Exp As String = "qryExp"
Const strMdbQry_SPL As String = "qrySPL"
Const strMdbQry_Organic As String = "qryOrganic"
Const strMdbQry_OrganicTransferTo As String = "qryOrganicTransferTo"

Dim MySel As Object

'Main program for Consolidation
Public Sub Consolidate()
ExpChecker
ExpClearContents
ExpCreateMDB
ExpExportData
ExpCompactDB
ExpImportData
End Sub

Private Sub ExpChecker()
Dim strXlsPath As String, strFilesInPath As String, strMyPrompt As String

strXlsPath = ThisWorkbook.Path & "\For Consol\Expense\"

'If there are no Excel files in the folder exit the sub
strFilesInPath = Dir(strXlsPath & "*.xls")
If strFilesInPath = "" Then
strMyPrompt = "No Excel file found!!!" & _
(Chr(13) & Chr(10)) & (Chr(13) & Chr(10)) & _
"- Excel file should be in the 'For Consol\Expense\ folder'."
MsgBox strMyPrompt, vbCritical, "Error: Consolidation"
End
End If

With Worksheets("GAEandCAPEXSummary")
If .Range("BudgetYr") = "" Then
MsgBox "Please Input Budget Year", vbCritical, "Data Required"
End
End If
End With
End Sub

'Clear the contents
Public Sub ExpClearContents()
Dim varUserData As Variant
Dim intCounter As Integer

varUserData = Array("GAE_EmpRelExp", "GAE_CompRelExp", "GAE_CustRelExp", _
"GAE_FixedOprtgExp", "CAPEX")

Application.ScreenUpdating = False

With Worksheets("GAEandCapexSummary")
.Unprotect modConsolExpMisc.strPassword
For intCounter = 1 To UBound(varUserData)
.Range("UserData_" & varUserData(intCounter)).ClearContents
Next intCounter
.Protect modConsolExpMisc.strPassword
End With

Application.ScreenUpdating = True
End Sub

'Create an MDB File using DAO
Private Sub ExpCreateMDB()
'Common Variables
Dim dbMdb As Database
Dim strMdbPath As String
Dim intCounter As Integer

'Variables for Expense
Dim tdTblDef_Exp As TableDef
Dim qdQryDef_Exp As QueryDef, qdQryDef_SPL As QueryDef
Dim strSQL_Exp As String, strSQL_SPL As String
Dim varTblHeader_Exp As Variant

'Variables for Organic
Dim tdTblDef_Organic As TableDef
Dim qdQryDef_Organic As QueryDef, qdQryDef_OrganicTransferTo As QueryDef
Dim strSQL_Organic As String, strSQL_OrganicTransferTo As String
Dim varTblHeader_Organic As Variant

'Variables for Subcon
Dim tdTblDef_Subcon As TableDef
Dim varTblHeader_Subcon As Variant

'Variables for Capex
Dim tdTblDef_Capex As TableDef
Dim varTblHeader_Capex As Variant

'Variables for Depreciation
Dim tdTblDef_DepreciationExisting As TableDef, tdTblDef_DepreciationNew As TableDef
Dim varTblHeader_Depreciation As Variant

varTblHeader_Exp = Array("Filename", "DeptBranch", "CRC", "RC", "Location", "LocCode", _
"RefCode", "ActualTotal", "ActualAnnualized", "ActualRvsed", "Reforecast", "ProjTotal", _
"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

'Consist of Filename, Location, Dept, Name, JobPos, JobLevel, and EmpType
varTblHeader_Organic = Array("Filename", "Location", "Dept", "EmpName", _
"EmpType", "JobPos", "JobLevel", "TransferFromTo", "TransferDept", "Ind_Transfer")

varTblHeader_Subcon = Array("Filename", "Location", "Dept", "Services", _
"IDNumber", "Deployment", "ServiceProvider", "Rate", "Unit")

varTblHeader_Capex = Array("Dept", "CRC", "LocDesc", "LocCode", "Category", "Particular", "Qty", "UnitCostPerQty", "Amount", _
"BudgetedMonth", "TotalDep", "JanDep", "FebDep", "MarDep", "AprDep", "MayDep", "JunDep", _
"JulDep", "AugDep", "SepDep", "OctDep", "NovDep", "DecDep")

varTblHeader_Depreciation = Array("Filename", "Dept", "Category", "Total", "Jan", "Feb", "Mar", _
"Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

strMdbPath = ThisWorkbook.Path & "\" & strMdbFilename

'If the MDB file already exists, KILL it.
If Dir(strMdbPath) <> "" Then Kill strMdbPath

'Make a MDB file
Set dbMdb = CreateDatabase(strMdbPath, dbLangGeneral)

'Make a TableDef
With dbMdb
Set tdTblDef_Exp = .CreateTableDef(strMdbTbl_Exp)
Set tdTblDef_Organic = .CreateTableDef(strMdbTbl_Organic)
Set tdTblDef_Subcon = .CreateTableDef(strMdbTbl_Subcon)
Set tdTblDef_Capex = .CreateTableDef(strMdbTbl_Capex)
Set tdTblDef_DepreciationExisting = .CreateTableDef(strMdbTbl_DepreciationExisting)
Set tdTblDef_DepreciationNew = .CreateTableDef(strMdbTbl_DepreciationNew)
End With

With tdTblDef_Exp
'Field for Filename, DeptBranch, CRC, RC, Location, LocCode, and RefCode
'in varTblHeader_Exp
For intCounter = 1 To 7
.Fields.Append .CreateField(varTblHeader_Exp(intCounter), dbText)
Next intCounter

'Remaining field in varTblHeader_Exp (ex: Actual, Proj Total, Jan-Dec)
For intCounter = 8 To UBound(varTblHeader_Exp)
.Fields.Append .CreateField(varTblHeader_Exp(intCounter), dbDouble)
Next intCounter
End With

With tdTblDef_Organic
For intCounter = 1 To UBound(varTblHeader_Organic)
.Fields.Append .CreateField(varTblHeader_Organic(intCounter), dbText)
Next intCounter
End With

With tdTblDef_Subcon
For intCounter = 1 To UBound(varTblHeader_Subcon) - 2
.Fields.Append .CreateField(varTblHeader_Subcon(intCounter), dbText)
Next intCounter
.Fields.Append .CreateField(varTblHeader_Subcon(8), dbDouble)
.Fields.Append .CreateField(varTblHeader_Subcon(9), dbText)
End With

With tdTblDef_Capex
For intCounter = 1 To 6
.Fields.Append .CreateField(varTblHeader_Capex(intCounter), dbText)
Next intCounter

For intCounter = 7 To 9
.Fields.Append .CreateField(varTblHeader_Capex(intCounter), dbDouble)
Next intCounter

.Fields.Append .CreateField(varTblHeader_Capex(10), dbText)

For intCounter = 11 To 23
.Fields.Append .CreateField(varTblHeader_Capex(intCounter), dbDouble)
Next intCounter
End With

With tdTblDef_DepreciationExisting
For intCounter = 1 To 3
.Fields.Append .CreateField(varTblHeader_Depreciation(intCounter), dbText)
Next intCounter

For intCounter = 4 To UBound(varTblHeader_Depreciation)
.Fields.Append .CreateField(varTblHeader_Depreciation(intCounter), dbDouble)
Next intCounter
End With

With tdTblDef_DepreciationNew
For intCounter = 1 To 3
.Fields.Append .CreateField(varTblHeader_Depreciation(intCounter), dbText)
Next intCounter

For intCounter = 4 To UBound(varTblHeader_Depreciation)
.Fields.Append .CreateField(varTblHeader_Depreciation(intCounter), dbDouble)
Next intCounter
End With

'Make a QueryDef
With dbMdb
Set qdQryDef_Exp = .CreateQueryDef(strMdbQry_Exp)
Set qdQryDef_SPL = .CreateQueryDef(strMdbQry_SPL)
Set qdQryDef_Organic = .CreateQueryDef(strMdbQry_Organic)
Set qdQryDef_OrganicTransferTo = .CreateQueryDef(strMdbQry_OrganicTransferTo)
End With

strSQL_Exp = "SELECT RefCode, "
strSQL_Exp = strSQL_Exp & "Sum(ActualTotal) AS SumOfActualTotal, Sum(ActualAnnualized) AS SumOfActualAnnualized, "
strSQL_Exp = strSQL_Exp & "Sum(ActualRvsed) AS SumOfActualRvsed, Sum(Reforecast) AS SumOfReforecast, "
strSQL_Exp = strSQL_Exp & "Sum(ProjTotal) AS SumOfProjTotal, "
strSQL_Exp = strSQL_Exp & "Sum(Jan) AS SumOfJan, Sum(Feb) AS SumOfFeb, Sum(Mar) AS SumOfMar, "
strSQL_Exp = strSQL_Exp & "Sum(Apr) AS SumOfApr, Sum(May) AS SumOfMay, Sum(Jun) AS SumOfJun, "
strSQL_Exp = strSQL_Exp & "Sum(Jul) AS SumOfJul, Sum(Aug) AS SumOfAug, Sum(Sep) AS SumOfSep, "
strSQL_Exp = strSQL_Exp & "Sum(Oct) AS SumOfOct, Sum(Nov) AS SumOfNov, Sum(Dec) AS SumOfDec "
strSQL_Exp = strSQL_Exp & "FROM tblExp GROUP BY RefCode"
qdQryDef_Exp.Sql = strSQL_Exp

strSQL_SPL = "SELECT LocCode, Location, "
strSQL_SPL = strSQL_SPL & "Sum(ActualTotal) AS SumOfActualTotal, Sum(ActualAnnualized) AS SumOfActualAnnualized, Sum(ProjTotal) AS SumOfProjTotal, "
strSQL_SPL = strSQL_SPL & "Sum(Jan) AS SumOfJan, Sum(Feb) AS SumOfFeb, Sum(Mar) AS SumOfMar, "
strSQL_SPL = strSQL_SPL & "Sum(Apr) AS SumOfApr, Sum(May) AS SumOfMay, Sum(Jun) AS SumOfJun, "
strSQL_SPL = strSQL_SPL & "Sum(Jul) AS SumOfJul, Sum(Aug) AS SumOfAug, Sum(Sep) AS SumOfSep, "
strSQL_SPL = strSQL_SPL & "Sum(Oct) AS SumOfOct, Sum(Nov) AS SumOfNov, Sum(Dec) AS SumOfDec "
strSQL_SPL = strSQL_SPL & "FROM tblExp WHERE RefCode IN ('8030000000', '2030000000') "
strSQL_SPL = strSQL_SPL & "GROUP BY LocCode, Location"
qdQryDef_SPL.Sql = strSQL_SPL

'Query - do not include "Transfer To" employee
strSQL_Organic = "SELECT Filename, Location, Dept, EmpName, EmpType, JobPos, JobLevel, Count(EmpName) AS Count "
strSQL_Organic = strSQL_Organic & "FROM tblOrganic GROUP BY Filename, Location, Dept, EmpName, EmpType, JobPos, JobLevel "
strSQL_Organic = strSQL_Organic & "HAVING Count(EmpName) = 1 ORDER BY Dept, EmpName;"
qdQryDef_Organic.Sql = strSQL_Organic

strSQL_OrganicTransferTo = "SELECT Filename, Location, Dept, EmpName, EmpType, JobPos, JobLevel, TransferDept "
strSQL_OrganicTransferTo = strSQL_OrganicTransferTo & "FROM tblOrganic WHERE Ind_Transfer = '2' "
strSQL_OrganicTransferTo = strSQL_OrganicTransferTo & "ORDER BY Dept, EmpName;"
qdQryDef_OrganicTransferTo.Sql = strSQL_OrganicTransferTo

With dbMdb.TableDefs
.Append tdTblDef_Exp
.Append tdTblDef_Organic
.Append tdTblDef_Subcon
.Append tdTblDef_Capex
.Append tdTblDef_DepreciationExisting
.Append tdTblDef_DepreciationNew
End With

qdQryDef_Exp.Close
qdQryDef_SPL.Close
qdQryDef_Organic.Close
qdQryDef_OrganicTransferTo.Close
dbMdb.Close
End Sub

'Export Data from Excel to Access using ADO
Private Sub ExpExportData()
'Common Variables
Dim cnn As ADODB.Connection
Dim strMdbPath As String, strXlsPath As String, strFilesInPath As String, _
strArrayMyFiles() As String
Dim lngFnum As Long, lngRow As Long, intCol As Integer
Dim varUserData As Variant
Dim intCounter1 As Integer, intCounter2 As Integer, intCounter3 As Integer

'Variables for Expense
Dim rst_Exp As ADODB.Recordset
Dim strSQL_Exp As String
Dim varBuf_Exp As Variant, varBuf_HeaderData As Variant, varTblHeader_Exp As Variant

'Variables for Organic
Dim rst_Organic As ADODB.Recordset
Dim strSQL_Organic As String
Dim varBuf_Organic As Variant, varEmpRange As Variant

'Variables for Subcon
Dim rst_Subcon As ADODB.Recordset
Dim strSQL_Subcon As String
Dim varBuf_Subcon As Variant, varSubconRange As Variant

'Variables for Capex
Dim rst_Capex As ADODB.Recordset
Dim strSQL_Capex As String
Dim varCapexData As Variant, varBuf_CapexCategory As Variant, varBuf_CapexData As Variant

'Variables for Depreciation
Dim rst_DepreciationExisting As ADODB.Recordset, rst_DepreciationNew As ADODB.Recordset
Dim strSQL_DepreciationExisting As String, strSQL_DepreciationNew As String
Dim varBuf_DepreciationExisting As Variant, varBuf_DepreciationNew As Variant

varTblHeader_Exp = Array("Filename", "DeptBranch", "CRC", "RC", "Location", "LocCode", _
"RefCode", "ActualTotal", "ActualAnnualized", "ActualRvsed", "Reforecast", "ProjTotal", _
"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

varUserData = Array("UserData_GAE_EmpRelExp", "UserData_GAE_CompRelExp", _
"UserData_GAE_CustRelExp", "UserData_GAE_FixedOprtgExp", "UserData_CAPEX")

varCapexData = Array("Aircraft", "AircraftEquipment", "LibraryMaterials", "ComputerEquipment", _
"CompPrgDevtCost", "FurnFixEquip", "ServiceVehicle", "CommunicationEquipment", _
"Tools", "HangarGroundEquipment", "ForwardingTrucks", "Building", "Land", _
"LandImprovement", "LeaseholdImprovement", "BrandIdentity")

varEmpRange = Array("EmpRange", "NewEmp_EmpRange", "TransferEmp_EmpRange")
varSubconRange = Array("GeneralExisting", "GeneralNew", "JanitorialExisting", "JanitorialNew")

Set cnn = New ADODB.Connection
Set rst_Exp = New ADODB.Recordset
Set rst_Organic = New ADODB.Recordset
Set rst_Subcon = New ADODB.Recordset
Set rst_Capex = New ADODB.Recordset
Set rst_DepreciationExisting = New ADODB.Recordset
Set rst_DepreciationNew = New ADODB.Recordset

strMdbPath = ThisWorkbook.Path & "\" & strMdbFilename
strXlsPath = ThisWorkbook.Path & "\For Consol\Expense\"

'Add a slash at the end if the user forget it
If Right(strXlsPath, 1) <> "\" Then
strXlsPath = strXlsPath & "\"
End If

Application.ScreenUpdating = False

'Fill the array(myFiles) with the list of Excel files in the folder
lngFnum = 0
strFilesInPath = Dir(strXlsPath & "*.xls")
Do While strFilesInPath <> ""
lngFnum = lngFnum + 1
ReDim Preserve strArrayMyFiles(1 To lngFnum)
strArrayMyFiles(lngFnum) = strFilesInPath
strFilesInPath = Dir()
Loop

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strMdbPath & ";"

'Delete a previous data from the table
strSQL_Exp = "DELETE * FROM " & strMdbTbl_Exp
strSQL_Organic = "DELETE * FROM " & strMdbTbl_Organic
strSQL_Subcon = "DELETE * FROM " & strMdbTbl_Subcon
strSQL_Capex = "DELETE * FROM " & strMdbTbl_Capex
strSQL_DepreciationExisting = "DELETE * FROM " & strMdbTbl_DepreciationExisting
strSQL_DepreciationNew = "DELETE * FROM " & strMdbTbl_DepreciationNew

With cnn
.Execute (strSQL_Exp)
.Execute (strSQL_Organic)
.Execute (strSQL_Subcon)
.Execute (strSQL_Capex)
.Execute (strSQL_DepreciationExisting)
.Execute (strSQL_DepreciationNew)
End With

'Select the table
strSQL_Exp = "SELECT * FROM " & strMdbTbl_Exp
strSQL_Organic = "SELECT * FROM " & strMdbTbl_Organic
strSQL_Subcon = "SELECT * FROM " & strMdbTbl_Subcon
strSQL_Capex = "SELECT * FROM " & strMdbTbl_Capex
strSQL_DepreciationExisting = "SELECT * FROM " & strMdbTbl_DepreciationExisting
strSQL_DepreciationNew = "SELECT * FROM " & strMdbTbl_DepreciationNew

rst_Exp.Open strSQL_Exp, cnn, adOpenStatic, adLockOptimistic
rst_Organic.Open strSQL_Organic, cnn, adOpenStatic, adLockOptimistic
rst_Subcon.Open strSQL_Subcon, cnn, adOpenStatic, adLockOptimistic
rst_Capex.Open strSQL_Capex, cnn, adOpenStatic, adLockOptimistic
rst_DepreciationExisting.Open strSQL_DepreciationExisting, cnn, adOpenStatic, adLockOptimistic
rst_DepreciationNew.Open strSQL_DepreciationNew, cnn, adOpenStatic, adLockOptimistic

If lngFnum > 0 Then
For lngFnum = LBound(strArrayMyFiles) To UBound(strArrayMyFiles)
varBuf_HeaderData = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
"HeaderData")

'Organic
For intCounter1 = 1 To UBound(varEmpRange)
varBuf_Organic = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
varEmpRange(intCounter1))
With rst_Organic
For lngRow = LBound(varBuf_Organic, 2) To UBound(varBuf_Organic, 2)
.AddNew
.Fields("Filename") = strArrayMyFiles(lngFnum)
.Fields("Location") = varBuf_HeaderData(0, 3)
.Fields("Dept") = varBuf_HeaderData(0, 0)
.Fields("EmpName") = varBuf_Organic(0, lngRow)
.Fields("EmpType") = varBuf_Organic(1, lngRow)
.Fields("JobPos") = varBuf_Organic(2, lngRow)
.Fields("JobLevel") = varBuf_Organic(3, lngRow)
.Fields("Ind_Transfer") = 0
If varEmpRange(intCounter1) = "TransferEmp_EmpRange" Then
.Fields("TransferFromTo") = varBuf_Organic(8, lngRow)
.Fields("TransferDept") = varBuf_Organic(9, lngRow)
.Fields("Ind_Transfer") = varBuf_Organic(11, lngRow)
End If
If IsNull(.Fields("EmpName").Value) Then
.Delete
End If
.Update
Next lngRow
End With
Next intCounter1

'Subcon
For intCounter1 = 1 To UBound(varSubconRange)
varBuf_Subcon = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
varSubconRange(intCounter1) & "Info")
With rst_Subcon
For lngRow = LBound(varBuf_Subcon, 2) To UBound(varBuf_Subcon, 2)
.AddNew
.Fields("Filename") = strArrayMyFiles(lngFnum)
.Fields("Location") = varBuf_HeaderData(0, 3)
.Fields("Dept") = varBuf_HeaderData(0, 0)
.Fields("Services") = varSubconRange(intCounter1)
.Fields("IDNumber") = varBuf_Subcon(0, lngRow)
.Fields("Deployment") = varBuf_Subcon(1, lngRow)
.Fields("ServiceProvider") = varBuf_Subcon(2, lngRow)
.Fields("Rate") = varBuf_Subcon(3, lngRow)
If varSubconRange(intCounter1) = "ITServices" Then
.Fields("Unit") = "Per Month"
ElseIf varSubconRange(intCounter1) = "JanitorialExisting" Or _
varSubconRange(intCounter1) = "JanitorialNew" Then
.Fields("Unit") = "Per Day"
Else
.Fields("Unit") = varBuf_Subcon(4, lngRow)
End If
If IsNull(.Fields("IDNumber").Value) Then
.Delete
End If
.Update
Next lngRow
End With
Next intCounter1

'GAE
For intCounter1 = 1 To UBound(varUserData)
varBuf_Exp = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
varUserData(intCounter1))
With rst_Exp
For lngRow = LBound(varBuf_Exp, 2) To UBound(varBuf_Exp, 2)
.AddNew
.Fields("Filename") = strArrayMyFiles(lngFnum)
For intCounter2 = 1 To 5
.Fields(intCounter2) = varBuf_HeaderData(0, intCounter2 - 1)
Next intCounter2

'In MDB file, from RefCode to Dec field.
intCounter3 = 0
For intCounter2 = 6 To UBound(varTblHeader_Exp) - 1
.Fields(intCounter2) = varBuf_Exp(intCounter3, lngRow)
intCounter3 = intCounter3 + 1
Next intCounter2
If (.Fields("ProjTotal").Value = 0 And .Fields("ActualTotal").Value = 0) Or _
(IsNull(.Fields("ProjTotal").Value) And IsNull(.Fields("ActualTotal").Value)) Or _
(.Fields("ProjTotal").Value = 0 And IsNull(.Fields("ActualTotal").Value)) Then
.Delete
End If
.Update
Next lngRow
End With
Next intCounter1

'Capex
For intCounter1 = 1 To UBound(varCapexData)
varBuf_CapexCategory = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
"Capex_" & varCapexData(intCounter1) & "_Start")

For intCounter2 = 1 To 2
varBuf_CapexData = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
"Capex_" & varCapexData(intCounter1) & "_Data" & intCounter2)

With rst_Capex
For lngRow = LBound(varBuf_CapexData, 2) To UBound(varBuf_CapexData, 2)
.AddNew
.Fields("Dept") = varBuf_HeaderData(0, 0)
.Fields("CRC") = varBuf_HeaderData(0, 1)
.Fields("LocDesc") = varBuf_HeaderData(0, 3)
.Fields("LocCode") = varBuf_HeaderData(0, 4)
.Fields("Category") = varBuf_CapexCategory(0, 0)
.Fields("Particular") = varBuf_CapexData(0, lngRow) & " - " & varBuf_CapexData(1, lngRow)
.Fields("Qty") = varBuf_CapexData(2, lngRow)
.Fields("UnitCostPerQty") = varBuf_CapexData(3, lngRow)
.Fields("BudgetedMonth") = varBuf_CapexData(4, lngRow)
.Fields("Amount") = varBuf_CapexData(6, lngRow)
.Fields("TotalDep") = varBuf_CapexData(20, lngRow)
.Fields("JanDep") = varBuf_CapexData(21, lngRow)
.Fields("FebDep") = varBuf_CapexData(22, lngRow)
.Fields("MarDep") = varBuf_CapexData(23, lngRow)
.Fields("AprDep") = varBuf_CapexData(24, lngRow)
.Fields("MayDep") = varBuf_CapexData(25, lngRow)
.Fields("JunDep") = varBuf_CapexData(26, lngRow)
.Fields("JulDep") = varBuf_CapexData(27, lngRow)
.Fields("AugDep") = varBuf_CapexData(28, lngRow)
.Fields("SepDep") = varBuf_CapexData(29, lngRow)
.Fields("OctDep") = varBuf_CapexData(30, lngRow)
.Fields("NovDep") = varBuf_CapexData(31, lngRow)
.Fields("DecDep") = varBuf_CapexData(32, lngRow)
If .Fields("Amount").Value = 0 Or IsNull(.Fields("Amount").Value) Then
.Delete
End If
.Update
Next lngRow
End With
Next intCounter2
Next intCounter1

'Depreciation-Existing
varBuf_DepreciationExisting = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
"Depreciation_ExistingAsset")

With rst_DepreciationExisting
For lngRow = LBound(varBuf_DepreciationExisting, 2) To UBound(varBuf_DepreciationExisting, 2)
.AddNew
.Fields("Filename") = strArrayMyFiles(lngFnum)
.Fields("Dept") = varBuf_HeaderData(0, 0)
For intCol = LBound(varBuf_DepreciationExisting, 1) To UBound(varBuf_DepreciationExisting, 1)
'Fields in Access Table is always start in 1
.Fields(intCol + 2) = varBuf_DepreciationExisting(intCol, lngRow)
Next intCol
If .Fields("Total").Value = 0 Or IsNull(.Fields("Total").Value) Then
.Delete
End If
.Update
Next lngRow
End With

'Depreciation-New
varBuf_DepreciationNew = ReadDataFromWorkbook(strXlsPath & strArrayMyFiles(lngFnum), _
"Depreciation_NewCapex")

With rst_DepreciationNew
For lngRow = LBound(varBuf_DepreciationNew, 2) To UBound(varBuf_DepreciationNew, 2)
.AddNew
.Fields("Filename") = strArrayMyFiles(lngFnum)
.Fields("Dept") = varBuf_HeaderData(0, 0)
For intCol = LBound(varBuf_DepreciationNew, 1) To UBound(varBuf_DepreciationNew, 1)
'Fields in Access Table is always start in 1
.Fields(intCol + 2) = varBuf_DepreciationNew(intCol, lngRow)
Next intCol
If .Fields("Total").Value = 0 Or IsNull(.Fields("Total").Value) Then
.Delete
End If
.Update
Next lngRow
End With
Next lngFnum
End If

rst_Exp.Close
rst_Organic.Close
rst_Subcon.Close
rst_Capex.Close
rst_DepreciationExisting.Close
rst_DepreciationNew.Close
Set rst_Exp = Nothing
Set rst_Organic = Nothing
Set rst_Subcon = Nothing
Set rst_Capex = Nothing
Set rst_DepreciationExisting = Nothing
Set rst_DepreciationNew = Nothing

cnn.Close
Set cnn = Nothing

Application.ScreenUpdating = True
End Sub

Private Sub ExpCompactDB()
DBEngine.CompactDatabase ThisWorkbook.Path & "\" & strMdbFilename, _
ThisWorkbook.Path & "\" & "NewExpConsolDB.mdb"
Kill ThisWorkbook.Path & "\" & strMdbFilename
Name ThisWorkbook.Path & "\" & "NewExpConsolDB.mdb" As ThisWorkbook.Path & "\" & strMdbFilename
End Sub

'Import Data from Access to Excel using ADO
Private Sub ExpImportData()
Dim cnn As ADODB.Connection, rst As ADODB.Recordset
Dim strMdbPath As String
Dim rngCell As Range
Dim intCol As Integer, intRow As Integer
Dim blnFound As Boolean

strMdbPath = ThisWorkbook.Path & "\" & strMdbFilename
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strMdbPath & ";"

Application.ScreenUpdating = False

Worksheets("GAEandCAPEXSummary").Unprotect modConsolExpMisc.strPassword

With rst
.Open strMdbQry_Exp, cnn, adOpenForwardOnly, , adCmdTable
StartLoop:
Do Until rst.EOF
With Worksheets("GAEandCAPEXSummary")
For Each rngCell In .Range("GAECAPEXRefCode")
If rngCell = rst.Fields("RefCode") Then
intRow = rngCell.Row
blnFound = True
End If
If blnFound = True Then
For intCol = 3 To rst.Fields.Count + 1
.Cells(intRow, intCol).Value = rst.Fields(intCol - 2).Value
Next intCol
blnFound = False
rst.MoveNext
GoTo StartLoop
End If
Next rngCell
End With
Loop
End With

Worksheets("GAEandCAPEXSummary").Protect modConsolExpMisc.strPassword

Application.ScreenUpdating = True
End Sub

'Read data in a closed workbook
Private Function ReadDataFromWorkbook(SourceFile As String, SourceRange As Variant) As Variant
Dim cnn As ADODB.Connection, rst As ADODB.Recordset
Dim strConnection As String, strMyPrompt As String

strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"

Set cnn = New ADODB.Connection
On Error GoTo ErrorHandler
cnn.Open strConnection
Set rst = cnn.Execute("[" & SourceRange & "]")
On Error GoTo 0
ReadDataFromWorkbook = rst.GetRows 'returns a two dim array with all records in rst
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
On Error GoTo 0
Exit Function

ErrorHandler:
strMyPrompt = "The Source File or Source Range is invalid!"

MsgBox strMyPrompt, vbCritical, "Error: Consolidation"
Set rst = Nothing
Set cnn = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

'Terminates execution
End
End Function

[mdmackillop]

Hi Lucas,
Is all your data in Sheet1 in all of your workbooks, or do they contain multiple sheets to be consolidated?

[mdmackillop]

Apologies for missing your posting in the other thread.
Try the following.
Option Explicit
Option Compare Text
Sub Consolidate()
Dim tgt As Range, Source As Range, CkRange As Range, Cel As Range
Dim Rw As Long, i As Long, Dt As Range
Dim c As Range
Dim WB As Workbook, w As Workbook
Dim ws As Worksheet


Application.ScreenUpdating = False
Set WB = ActiveWorkbook
i = 1
'Loop through each sheet after first
For Each w In Workbooks
If w.Name <> WB.Name And w.Name <> "Personal.xls" Then
Set ws = w.Worksheets(1)
'Find place to post result
Set tgt = WB.Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'w.Activate
'Sheets(1).Activate
'Find data to copy and copy to target
Set Source = Range(ws.Cells(1, 1), ws.Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
Source.Interior.ColorIndex = 6
Rw = Source.Rows.Count
Source.Copy tgt
'Insert - at any blank cells
Set CkRange = tgt.Offset(, 1).Resize(Rw)
For Each Cel In CkRange
If Len(Cel) = 0 Then Cel = "-"
Next
'Move data to corresponding column
i = i + 1
CkRange.Cut tgt.Offset(, i - 1)
End If
Next
Sheets("Summary").Activate

'Part 2
'Find end of copied data
With WB.Sheets("Summary")
Rw = .Cells(Rows.Count, 1).End(xlUp).Row
Do
'Read last cell
Set Dt = .Cells(Rw, 1)
'Find location if date occurred before
Set c = Range(.Cells(1, 1), .Cells(Rw - 1, 1)).Find(Dt.Value, After:=.Cells(1, 1), LookIn:=xlFormulas)
'If found, move corresponding value to first found value
If Not c Is Nothing Then
Dt.End(xlToRight).Cut Cells(c.Row, Dt.End(xlToRight).Column)
Dt.EntireRow.Delete
End If
'Check next cell
Rw = Rw - 1
Loop Until Rw = 1
End With
Application.ScreenUpdating = True
End Sub

[LucasLondon]

Hi,

Thanks for the code. Answer to your question which you've probably already worked out is yes all my data is in the first sheet of all the workbooks althougth they may not all necessarily be named as Sheet1.

Anyway, I tried running your ammended code but it returns the VB error 400 in a message box?

Thanks,

Lucas

[mdmackillop]

Can you step through and let me know where the error occurs.

[LucasLondon]

Hi mdmackillop,

Sorry It was my fault, I'd pasted the data into a worksheet as opposed to within a module!

But whilst this thread fresh in our minds, going back to your orginal question ("Is all your data in Sheet1 in all of your workbooks, or do they contain multiple sheets to be consolidated?"), if data was actually spread accross mutiple sheets in different workbooks as opposed to just in sheet1, would it be easy to change the code to reflect this? It might be that at some point it is very likely that my set up would change so that I would need to consolidate mutiple data sheets within workbooks as well as accross workbooks.

Thanks,

Lucas

[mdmackillop]

Hi Lucas,
Basically, you would need to add another loop before this line

Set ws = w.Worksheets(1)


where 1 would be replaced by a variable.