Excel 2007 Macro To Aggregate Multiple Worksheet Totals


Hoping someone can assist in developing a macro that will look at multiple worksheets and aggregate column data into a Summary worksheet.  Sample attached.  Please note that the order the evaluator names are in can differ from worksheet to worksheet and there might be a name on one that does not appear in the others.  I've included 3 individual worksheets and a summary page but in the real report will have about 24 worksheets that need to be aggregated so hoping that it will be easy for me to go into the code and add the additional worksheets.

Thank you!
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

see attached file. run the macro called  CopyRangeFromMultiWorksheets

it will combine all the worksheets into the summary worksheet.
EscanabaAuthor Commented:
Thank you for the quick response.  I tested your macro and I think you're close.  Is there a way to set it up so that instead of repeating the data there is only one instance of the evaluator name and their totals aggregated for all worksheets?  For example, instead of having 3 individual George Washington's there would be only one and his total average score would be the aggregate of all three worksheets (17.75).
is your other sheets are always 6 columns? i mean from A to F?
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

does it have to be VBA ? or formula with using Indirect can be acceptable?   is all of your source sheets names are identical like Q_3.a.DEV , then b , c , e , f ,g ,h and so on.

i would try to come up with somthing, but if it has to  be vba then, there are very smart gurus in this forum that can do that in a blink. lets see
EscanabaAuthor Commented:
Yes - Always A - F
Yes - Source sheet names are identical starting at Q_3.b.DEV and ending at Q_5.d.DEV but there is always the potential for new source files down the road

There is already an existing VBA that takes the raw data which is a complete mess and restructures it so my reporting software can actually use it.  I was hoping this new VBA code would be a companion piece that I could add in for a summary sheet.
Glenn RayExcel VBA DeveloperCommented:
Hello again.  This code will create a summary sheet showing the totals of the scores in columns B, C, and D on each sheet for each unique evaluator.  It will sort the results by evaluator name.

This subroutine could be added to an existing module and could be called at the end of existing code simply by adding

Open in new window

near the end of your current sheet-building code (which I seem to recall... :-)   )
Option Explicit
Sub Summarize_Scores()
    Dim arrEval(), arrScores(100, 4) As Variant
    Dim ev, r, sh, x As Integer
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error Resume Next
    Sheets.Add before:=Sheets(1)
    ActiveSheet.Name = "Summary"
    Range("A1").Value = "Evaluator Name"
    Range("B1").Value = "Total Score"
    Range("C1").Value = "Total Organizational Score"
    Range("D1").Value = "Total No. of Evaluations"
    'Create list of evaluators
    r = 2
    For sh = 2 To Sheets.Count
        x = 2
        Do Until Sheets(sh).Cells(x, 1).Value = ""
            Cells(r, 1).Value = Sheets(sh).Cells(x, 1).Value
            r = r + 1
            x = x + 1
    Next sh
    'remove duplicates and assign evaluator names to array
    ActiveSheet.Range("A1:D" & r).RemoveDuplicates Columns:=1, Header:=xlYes
    ReDim arrEval(Range("A2").End(xlDown).Row)
    r = 2
    Do Until Cells(r, 1).Value = ""
        arrEval(r - 1) = Cells(r, 1).Value
        r = r + 1
    'Build arrScores from each sheet
    For sh = 2 To Sheets.Count
        With Sheets(sh)
            r = 2
            Do Until .Cells(r, 1).Value = ""
                For ev = 1 To UBound(arrEval())
                    If arrEval(ev) = .Cells(r, 1).Value Then
                        x = ev
                    End If
                Next ev
                arrScores(x, 1) = arrScores(x, 1) + .Cells(r, 2).Value
                arrScores(x, 2) = arrScores(x, 2) + .Cells(r, 3).Value
                arrScores(x, 3) = arrScores(x, 3) + .Cells(r, 4).Value
                r = r + 1
        End With
    Next sh
    'insert array values into Summary sheet
    For r = 1 To UBound(arrEval)
        Cells(r + 1, 2).Value = arrScores(r, 1)
        Cells(r + 1, 3).Value = arrScores(r, 2)
        Cells(r + 1, 4).Value = arrScores(r, 3)
    Next r
    'Sort summary sheet by Evaluator name and reformat columns and data
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("A2:A" & r) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Summary").Sort
        .SetRange Range("A1:D" & r)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
    End With
    Range("B2", Cells.SpecialCells(xlLastCell)).NumberFormat = "0.00"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Open in new window

An example workbook is attached.  No Summary sheet is shown; run the macro to see it created.

Glenn RayExcel VBA DeveloperCommented:

Did you have any other questions or issues?  I believe my solution (40360710) meets your needs.  If you agree can you please click the "Accept this solution" link above that post and properly close this question?

If not, please let me know and I'll be glad to help.


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
EscanabaAuthor Commented:
Glenn my apologies - I've been away from work due to a passing in the family and been playing catch up for the past week.  Thank you for your assistance.
Glenn RayExcel VBA DeveloperCommented:
Sorry about your loss.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.