Solved: Advanced consolidation help!!

[mancubus]

hi

i tested on sample workbooks and i think below procedure did the trick.
i recommend you do the same and first test the code on sample files.

macro file is attached. opens a file named "Consolidated Reports.xls" which is already created.

[VBA]
Sub consWBs()
'http://vbaexpress.com/forum/showthread.php?t=39367
'requires a reference to Microsoft Scripting Runtime

Dim fso As Object, fsoFolder As Object, fsoSubfolder As Object
Dim wbMaster As Workbook, wbData As Workbook, wsMaster As Worksheet
Dim folderPath As String, subfolderName As String, wbMasterName As String
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long


With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With

Set fso = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Data\"
Set fsoFolder = fso.GetFolder(folderPath)

wbMasterName = "Consolidated Reports.xls"
If IsWbOpen(wbMasterName) Then
Set wbMaster = Workbooks(wbMasterName)
Else
Set wbMaster = Workbooks.Open(folderPath & wbMasterName)
End If

With wbMaster
For Each fsoSubfolder In fsoFolder.SubFolders
subfolderName = fsoSubfolder.Name
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = subfolderName
Set wsMaster = ActiveSheet
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.Cells.Clear
NR = 1
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = folderPath & subfolderName & "\" 'remember final \ in this string
fPathDone = fPath & "\Imported\" 'remember final \ in this string

If Len(Dir(fPathDone, vbDirectory)) = 0 Then
MkDir fPathDone
End If

fName = Dir(fPath & "*.xls*") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
LR = Range("A" & Rows.Count).End(xlUp).Row 'Find last row
If NR = 1 Then 'copy the data AND titles
Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
Else 'copy the data only
Range("A2:A" & LR).EntireRow.Copy .Range("A" & NR)
End If
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & "\" & fName 'move file to IMPORTED folder
fName = Dir 'ready next filename
End If
Loop
End With
Next
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With

End Sub


Function IsWbOpen(wbName As String) As Boolean
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=443

Dim i As Long
For i = Workbooks.Count To 1 Step -1
If Workbooks(i).Name = wbName Then Exit For
Next
If i <> 0 Then IsWbOpen = True

End Function

[/VBA]