Macro for consolidating files back into one workbook

[Drexl27]

Hi All,

In the attached spreadsheet, I have a macro that splits up the data based on category and creates 9 separate files within the same folder.

These files are then looked at and updated by other employees, and what I'm looking for is a macro that will then take the updated 9 files and consolidate them back into the original workbook on a new Sheet, in the same format that they are originally (but with updated numbers of course).

Let me know if you can help, or if you need any more information.

Thanks!general 2015 percentages.xlsm

[Doc.AElstein]

Hi Drexl27,
. Here is a basic solution. Probably not too efficient as it interacts a lot with the spreadsheet and there are some extra bits to make to a bit more understandable, etc..
.
. Try it out, let me know how you get on, and if necessary I / we can improve / change it.
.
. To make this code work i modified your code which saves the Group Files Thus:

Sub SaveGroupFiles()
    Dim x As Long
    Dim stFolder As String, stFName As String
    stFolder = ActiveWorkbook.Path
    Range("Data").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("lst_group"), unique:=True
    Application.DisplayAlerts = False
    For x = 1 To Range("lst_group").Cells(1, 2)
        Range("crit").Cells(2, 1).Value = Range("lst_group").Cells(x + 1, 1).Value
        stFName = Range("lst_group").Cells(x + 1, 1).Value & Format(Date, "mmddyyyy") & Format(Time, "hhmm")
        Cells(1, Columns.Count).End(xlToLeft).Offset(x, 1).Value = stFName
        Range("Data").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("dataout"), criteriarange:=Range("crit")
        Sheet3.Copy
        ActiveWorkbook.SaveAs Filename:=stFolder & "\" & stFName
        ActiveWorkbook.Close
    Next x
End Sub

... The modification gives a Range filled with the last made Group file names Thus:

Using Excel 2007

Row\Col	AL	AM	AN
1	Group
2	AP	Comm Acct080620152336
3		HR080620152336
4		Prop Acct080620152336
5		Office Services080620152336
6		Corp Acct080620152336
7		IT080620152336
8		Payroll080620152336
9		CFO080620152336
10		AP080620152336

gen.percents

.. This is needed for my following code to work.

Code:

'
Sub MakeUpdatedSheet() 'http://www.excelforum.com/excel-programming-vba-macros/1097815-macro-for-consolidating-files-back-into-one-workbook.html
Dim wbHere As Workbook: Set wbHere = ThisWorkbook
Dim ws1 As Worksheet, wsSummary As Worksheet 'First ws in This workbook, new Summary ws
Set ws1 = wbHere.Worksheets.Item(1)
wbHere.Worksheets.Add(After:=Worksheets(wbHere.Worksheets.Count)).Name = "Summary at " & Format(Date, "mmddyyyy")
Set wsSummary = ActiveSheet
ws1.Rows(1).Copy 'Copy headings from original first sheet
wsSummary.Rows(1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme 'Paste headings in new sheet

Dim myArr() As Variant: Let myArr() = ws1.Columns(ws1.Cells(2, Columns.Count).End(xlToLeft).Column).SpecialCells(xlCellTypeConstants).Value 'The cells of the last made sheets column with something in are the range assigned in the allowed "VBA one liner" to assign the values in a range to an Array.

Dim ws As Worksheet, wb As Workbook, Cnt As Long
    For Cnt = LBound(myArr(), 1) To UBound(myArr(), 1)
                'Workbooks.Open Filename:="F:\ExcelForum\Sorting\" & myArr(Cnt, 1) & ".xlsx"
    Workbooks.Open Filename:=wbHere.Path & "\" & myArr(Cnt, 1) & ".xlsx"
    Set wb = ActiveWorkbook: Set ws = wb.Worksheets("Sheet3")
    ws.Rows("2:" & ws.Cells(Rows.Count, 1).End(xlUp).Row & "").Copy
    wsSummary.Cells(Rows.Count, 1).End(3)(2).PasteSpecial Paste:=xlPasteAllUsingSourceTheme 'The Range (cell) thhat is next free in the Summary sheet is effectively used as the top left of where the range in the Clipbord is copied
    wb.Save: wb.Close 'Save, close the current wb
    Next Cnt
End Sub

...
. I have run the code a few times. It seems to work
Alan

[Drexl27]

This seems to be working really well! I'm going to tinker with it a big, although I'll probably have more time to do so on Monday. So if I find any bugs or issues that I think could be made better I'll report back here. Thanks!

[Doc.AElstein]

This seems to be working really well! I'm going to tinker with it a big, although I'll probably have more time to do so on Monday. So if I find any bugs or issues that I think could be made better I'll report back here. Thanks!

OK, thanks for the Feedback.