Tough One: Summarize Information from Multiple Worksheets

V

VBA_Newbie

Active Member
Joined
Jan 7, 2005
Messages
258
Hi all,

I've got a tough one today. I have a program which outputs a plethora of results into excel spreadsheets. It's a special type of analysis known as TURF (total unduplicated reach & frequency). The problem is that is does not summarize the output that are on multiple worksheets. I'm hoping to create a macro to do exactly that, however, the criteria to summarize the information is rather complex. I was hoping one of the VBA gurus might be able to get me started.

I'll try to walk whomever is reading this and perhaps might be able to help me tackle this problem through the output.

Below is the output on a sheet called COMBO-1 (the sheets are always labeled the same):
OVERALL_REACH_RG.xls
ABCD
1Col_nameCol_1-RchPercent
2Plain_Rg62534.34
3Garl_n_herbs_Rg61333.68
4Fine_herbs_Rg60833.41
5Brie_ch_Rg52028.57
6Swiss_ch_Rg51528.3
7Garden_veg_Rg45424.95
8tom_n_basil_Rg44624.51
9Fr_onions_Rg44424.4
10Brie_n_cran_Rg40822.42
11Goat_ch_Rg38120.93
12Blue_ch_Rg31117.09
Combo-1


Below is the output on a sheet called COMBO-2:
OVERALL_REACH_RG.xls
ABCDE
1Flavor_1Flavor_2Complem-RchSubset-RchPercent-Subset
2Plain_RgGarl_n_herbs_Rg123887848.24
3Plain_RgFine_herbs_Rg123386247.36
4Plain_RgBrie_ch_Rg114581945
5Plain_RgBrie_n_cran_Rg103381244.62
6Plain_Rgtom_n_basil_Rg107180344.12
7Swiss_ch_RgGarl_n_herbs_Rg112879743.79
8Brie_ch_RgGarl_n_herbs_Rg113379243.52
9Plain_RgSwiss_ch_Rg114079143.46
10Plain_RgFr_onions_Rg106978843.3
11Plain_RgGarden_veg_Rg107978643.19
12Swiss_ch_RgFine_herbs_Rg112378443.08
13Brie_ch_RgFine_herbs_Rg112878343.02
14Plain_RgGoat_ch_Rg100678142.91
Combo-2


The program creates up to 11 sheets in the same manner (COMBO-1, COMBO-2...COMBO-11). The sheets COMBO-2 to COMBO-11 follow the same type of structure, whereas the sheet COMBO-1 is slightly different. The only difference between sheets COMBO-2 to COMBO-11 is that there are extra columns for the number of flavours. That is, in COMBO-2 there are 2 columns labelled Flavor_1 & Flavor_2, in Combo-3 there will be 3 columns labelled Flavor_1, Flavor_2, & Flavor_3, and so on and so on.

A short history of what you're looking at to make things more interesting:

TURF (Total Unduplicated Reach and Frequency) analysis is a technique used in marketing research to maximize the unduplicated reach of a product line while minimizing that product line’s depth. It was a technique originally used by media planners attempting to build ‘reach’ for an advertisement across vehicles (print, broadcast, etc.) without duplicating audiences. Now, it is often used to choose the product lines, flavor bundles, colors, scents, package sizes, etc., to offer to potential buyers. In this scenario, I'm trying to show the optimal number of flavours that will maximize the reach of the line of products. That is which combinations of flavour will appeal to the most people and still be reasonable to offer. For instance, there is a cut off point where adding a new flavour will only appeal to very small number of additional people, and thus may not be justified.

Now that I've got that out of the way, here's what I'm trying to accomplish.

I want to have a macro which creates a sheet called SUMMARY. On that sheet it will summarize certain information from each of the sheets labelled Combo-1 to Combo-11 as in the sheet below.
OVERALL_REACH_RG.xls
ABCDEFGHIJKLM
1COMBOFlavour_1Flavour_2Flavour_3Flavour_4Flavour_5Flavour_6Flavour_7Flavour_8Flavour_9Flavour_10Flavour_11REACH
21Plain_Rg34.34
32Plain_RgGarl_n_herbs_Rg48.24
43Plain_RgGarl_n_herbs_Rg??????????
54Plain_RgGarl_n_herbs_Rg????????????????
65Plain_RgGarl_n_herbs_Rg????????????????????
76Plain_RgGarl_n_herbs_Rg?????????????????????????
87Plain_RgGarl_n_herbs_Rg??????????????????????????????
98Plain_RgGarl_n_herbs_Rg???????????????????????????????????
109Plain_RgGarl_n_herbs_Rg????????????????????????????????????????
1110Plain_RgGarl_n_herbs_Rg?????????????????????????????????????????????
1211Plain_RgGarl_n_herbs_Rg??????????????????????????????????????????????????
SUMMARY


The algorithm needed to populate a summary table like the above would have to work something like this.

Find the flavor with maximum reach in COMBO-1 (the flavor for which the number under column called 'percent' is the highest) and insert that flavor (text string) in worksheet "SUMMARY", cell B2 to B12. Insert the reach of that flavor into M2.

In worksheet COMBO-2, find the flavor combination which has the flavor from COMBO-1 and a new flavor that has the highest reach. Insert that new flavour into C3 to C12 and insert the reach from the column percent-subset into M3.

In worksheet COMBO-3, find the flavor combination that contains both the flavor from COMBO-1 & the new flavor added from COMBO-2 & and a new flavor that has the highest reach. Insert this 3rd flavour into D3 - D12 and insent the reach from the column percent-subset into M4.

And so on for all sheets upto Combo-11.

I know this is a long post, and not many people will want to help me tackle this. But I'm open to any suggestions that will help get me started.

Many thanks,
Mike
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
This is some very rough code and I don't have your workbook so I have no way to fully test it, but you can give this a shot. This code will make your summary sheet so make sure you don't already have a sheet named summary. If there are any problems, let me know.

Code: 
Sub SumData()
    Set NewSheet = Worksheets.Add
    NewSheet.Name = "SUMMARY"
    Dim cell As Range
    
    With Worksheets("SUMMARY")
        .Range("a1").Value = "COMBO"
        For i = 1 To 11
            .Range("a1").Offset(0, i).Value = "Flavour_" & i
        Next i
        .Range("m1").Value = "REACH"
        .Range("a2").Value = 1
        .Range("A2:A12").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Trend:=False
    End With
    
    'combo 1
    With Worksheets("COMBO-1")
    
        .Activate
    
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        maxval = Application.WorksheetFunction.Max(.Range(Cells(2, percol), Cells(maxrow, percol)))
        maxflav = Application.WorksheetFunction.Lookup(maxval, .Range(Cells(2, percol), Cells(maxrow, percol)), .Range(Cells(2, 1), Cells(maxrow, 1)))
        Worksheets("SUMMARY").Range("b2:b12").Value = maxflav
        Worksheets("SUMMAEY").Range("m2").Value = maxval
    End With
        
    'combo 2
    With Worksheets("COMBO-2")
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And cell.Value > maxval Then
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 2).Value
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("c3:c12").Value = maxflav
        Worksheets("SUMMARY").Range("m3").Value = maxval
        
    End With
        
        
        
    'combo 3
    With Worksheets("COMBO-3")
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                cell.Value > maxval Then
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 3).Value
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("d4:d12").Value = maxflav
        Worksheets("SUMMARY").Range("m4").Value = maxval
        
    End With
        
        
    'combo 4
    With Worksheets("COMBO-4") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 4).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("e5:e12").Value = maxflav '
        Worksheets("SUMMARY").Range("m5").Value = maxval '
        
    End With
    
    'combo 5
    With Worksheets("COMBO-5") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 5).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("f6:f12").Value = maxflav '
        Worksheets("SUMMARY").Range("m6").Value = maxval '
        
    End With
    
    'combo 6
    With Worksheets("COMBO-6") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    .Cells(cell.Row, 5).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 4).Value And _
                      cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 6).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("g7:g12").Value = maxflav '
        Worksheets("SUMMARY").Range("m7").Value = maxval '
        
    End With
        
    
    'combo 7
    With Worksheets("COMBO-7") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    .Cells(cell.Row, 5).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 4).Value And _
                      .Cells(cell.Row, 6).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 5).Value And _
                        cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 7).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("h8:h12").Value = maxflav '
        Worksheets("SUMMARY").Range("m8").Value = maxval '
        
    End With
    
    
    'combo 8
    With Worksheets("COMBO-8") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    .Cells(cell.Row, 5).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 4).Value And _
                      .Cells(cell.Row, 6).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 5).Value And _
                        .Cells(cell.Row, 7).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 6).Value And _
                          cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 8).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("I9:I12").Value = maxflav '
        Worksheets("SUMMARY").Range("m9").Value = maxval '
        
    End With
    
    
    'combo 9
    With Worksheets("COMBO-9") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    .Cells(cell.Row, 5).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 4).Value And _
                      .Cells(cell.Row, 6).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 5).Value And _
                        .Cells(cell.Row, 7).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 6).Value And _
                          .Cells(cell.Row, 8).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 7).Value And _
                            cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 9).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("J10:J12").Value = maxflav '
        Worksheets("SUMMARY").Range("m10").Value = maxval '
        
    End With
    
    'combo 10
    With Worksheets("COMBO-10") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    .Cells(cell.Row, 5).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 4).Value And _
                      .Cells(cell.Row, 6).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 5).Value And _
                        .Cells(cell.Row, 7).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 6).Value And _
                          .Cells(cell.Row, 8).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 7).Value And _
                            .Cells(cell.Row, 9).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 8).Value And _
                              cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 10).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("K11:K12").Value = maxflav '
        Worksheets("SUMMARY").Range("m11").Value = maxval '
        
    End With
    
    'combo 11
    With Worksheets("COMBO-11") '
    
        .Activate
        
        maxval = 0
        maxflav = ""
        maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column
            For Each cell In .Range(Cells(1, 1), Cells(1, maxcol))
            If Left(cell.Value, 7) = "Percent" Then
                percol = cell.Column
            End If
            Exit For
        Next cell
        
        For Each cell In .Range(Cells(2, percol), Cells(maxrow, percol))
            If .Cells(cell.Row, 1).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 0).Value And _
              .Cells(cell.Row, 2).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 1).Value And _
                .Cells(cell.Row, 3).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 2).Value And _
                  .Cells(cell.Row, 4).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 3).Value And _
                    .Cells(cell.Row, 5).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 4).Value And _
                      .Cells(cell.Row, 6).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 5).Value And _
                        .Cells(cell.Row, 7).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 6).Value And _
                          .Cells(cell.Row, 8).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 7).Value And _
                            .Cells(cell.Row, 9).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 8).Value And _
                              .Cells(cell.Row, 10).Value = Worksheets("SUMMARY").Range("b12").Offset(0, 9).Value And _
                                cell.Value > maxval Then '
                maxval = cell.Value
                maxflav = .Cells(cell.Row, 11).Value '
            End If
        Next cell
        
        Worksheets("SUMMARY").Range("L12:L12").Value = maxflav '
        Worksheets("SUMMARY").Range("m12").Value = maxval '
        
    End With
    
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Need VBA to filter blanks across several ranges and several worksheets
Replies
3
Views
471
John_w
J
R
  • Solved
VBA - Combine worksheets from multiple workbooks
Replies
5
Views
346
rachel06
R
B
  • Solved
Worksheet Change - multiple Loops in one sub
2
Replies
15
Views
812
mumps
mumps
R
  • Question Question
Replace links after moving worksheets from one workbook to another.
Replies
2
Views
381
RockandGrohl
R
D
  • Question Question
Multiple Monitors - tab selection
Replies
5
Views
287
Candyman8019
C

Forum statistics

Threads
1,223,910
Messages
6,175,318
Members
452,634
Latest member
cpostell

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top