Solved: Advanced consolidation help!!

[grini35]

I am new to VBA. I am working on a project that would be much easier to complete in Access, had I that option. Under the circumstances, I am attempting to create a database of the information I need.

What I have: 5 or 6 different reports supplied quarterly. Each report type is unique in its format, but constant over time. I have dropped all type 1 reports into a folder, type 2 reports into its own separate folder, etc.

What I want: Workbook that consists of worksheets where each worksheet is a compilation of a given report type. sheet 1, titled "type 1 report" would be a consolidation of all files in type 1 folder, sheet 2, titled "type 2 report" would be a consolidation of all the files in type 2 folder, etc.

I have found a few macros that can complete stages of this, but I want a file that can be updated with one macro. ANY help would be greatly appreciated!!

Thanks

[mancubus]

wellcome to VBAX.

here you may find different file merge examples.

http://www.rondebruin.nl/tips.htm

title:
Copy/Paste/Merge examples

[grini35]

I have triead altering some of the VBA's on that site in that last couple of days and have had little success getting to where I want to be.

What is the command to set the destination to an existing workbook?

[mancubus]

[VBA]Dim destWB as Workbook
set destWB = Workbooks("MyBook.xls")[/VBA]

[grini35]

OK.

I have had some success with the website that you referred me to. Thank you very much for that help.

I am still having a problem directing the output to where I would like.

I want to compile type A sheets to one tab in my output workbook, and type 2 sheets to a different tab, etc.

At this point, I am able to compile all sheets of a given type into the sheet I want. I would like to be able to repeat this function for the other types of files without having to run annother macro.

How can I make this change?

Also, I do not want the files to be relocated after I have pulled data.

[VBA]Option Explicit
Sub Consolidate()
'Summary: Merge files in a specific folder into one master sheet (stacked)
' Moves imported files into another folder
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now

Set wsMaster = ThisWorkbook.Sheets("Type1") 'sheet report is built into
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 = "C\ATA\Type1" 'remember final \ in this string
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
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
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub[/VBA]

[mancubus]

will try to help when i have time if not replied by someone else already.

btw, here are some Kb articles from VBAX.
http://vbaexpress.com/kb/getarticle.php?kb_id=151
http://www.vbaexpress.com/kb/getarticle.php?kb_id=773

[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]

[grini35]

Thank you for the help.

I am still having some trouble.

when I run the test, I am getting a run time error 1004. I have created a report titled "Consolidated Reports.xls" and have tried running the macro with the workbook open, closed, and in numerous locations.

This is what the debugger continues to highlight:
[VBA]Else
Set wbMaster = Workbooks.Open(folderPath & wbMasterName)[/VBA]

[mancubus]

check the location of Consolidated Reports.xls

[VBA]Set wbMaster = Workbooks.Open(folderPath & wbMasterName)[/VBA]
=
[VBA]Workbooks.Open "C:\Data\Consolidated Reports.xls"[/VBA]

[grini35]

The location seems correct.

Would the code change in the case of a network drive as oposed to a hard drive?

My files are currentl located on a network drive.

[mancubus]

one way is to use macro recorder for opening that specific file from network location. thus, you will get the necessary commands for correct path.

[grini35]

I tried that and think I may have been going about it wrong. I appreciate your help and if you have any further advice it too would be appreciated.

I am trying to find a way around this problem.

[grini35]

mancubus, I want to again thank you for your help. I have found the solution to my problems and have the vba running to my requirements, mostly thanks to you.

Cheers.

SOLUTION:

[vba]Option Explicit
Sub Generate_Report()
'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 = True
.EnableEvents = False
.DisplayAlerts = False
End With

Set fso = CreateObject("Scripting.FileSystemObject")
folderPath = "\" 'change this to your folder path
Set fsoFolder = fso.GetFolder(folderPath)

wbMasterName = "Reports.xlsx"
Set wbMaster = Workbooks.Open(folderPath & "\" & wbMasterName)


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


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
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]

[mancubus]

you are wellcome grini35.

pls mark the thread as solved from thread tools...