Data to be processed using VB Macro

N

Nitya0808

New Member
Joined
Jul 1, 2016
Messages
42
Hello All,

There is a set of data in sheet 1.

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Category[/TD]
[TD]Unit[/TD]
[TD]Period[/TD]
[TD]Data[/TD]
[TD]Lifecycle[/TD]
[/TR]
</tbody>[/TABLE]


There are 5 different units, and the categories can be similar or different across data. The data needs to categorized across units, per category, per period based on the lifecycle (only Active lifecycle is taken into calculation) in sheet 2.


Sheet 1


Book1
ABCDE
1CategoryUnitPeriodDataLifecycle
2AXP01345Active
3AXP01678Active
4AYP0232Mature
5BZP02567Active
6BZP0166Active
7BZP01-90Active
8CXP02100Active
9DYP0111223Active
10AXP02865Active
11AYP01124Mature
12CZP02674Active
13CZP02742Active
14CZP01983Active
15DWP01345Active
16DWP02742Active
17DWP02641Active
18AXP01578Not Applicable
19BYP01444Active
20CYP02980Active
Sheet1
Cell Formulas
RangeFormula
A1Category
A2A
A3A
A4A
A5B
A6B
A7B
A8C
A9D
A10A
A11A
A12C
A13C
A14C
A15D
A16D
A17D
A18A
A19B
A20C
B1Unit
B2X
B3X
B4Y
B5Z
B6Z
B7Z
B8X
B9Y
B10X
B11Y
B12Z
B13Z
B14Z
B15W
B16W
B17W
B18X
B19Y
B20Y
C1Period
C2P01
C3P01
C4P02
C5P02
C6P01
C7P01
C8P02
C9P01
C10P02
C11P01
C12P02
C13P02
C14P01
C15P01
C16P02
C17P02
C18P01
C19P01
C20P02
D1Data
D2345
D3678
D432
D5567
D666
D7-90
D8100
D911223
D10865
D11124
D12674
D13742
D14983
D15345
D16742
D17641
D18578
D19444
D20980
E1Lifecycle
E2Active
E3Active
E4Mature
E5Active
E6Active
E7Active
E8Active
E9Active
E10Active
E11Mature
E12Active
E13Active
E14Active
E15Active
E16Active
E17Active
E18Not Applicable
E19Active
E20Active


Sheet 2


Book1
BCDEFGHIJKLMNOP
4UnitCategoryP01P02P03P04P05P06P07P08P09P10P11P12Total
5XA1,023.001,023.00
6C865.00100.00965.00
7Total1,888.00100.001,988.00
8
9
10WD345.001,383.001,728.00
11Total345.001,383.000.000.000.000.000.000.000.000.000.000.001,728.00
12
13
14YD11223.0011,223.00
15B444.0032.00476.00
16C980.00980.00
17Total11,667.001,012.0012,679.00
18
19
20ZB-24.00567.00543.00
21C983.001,416.002,399.00
22Total959.001,983.002,942.00
23
24
25OverallA1023.00865.001,888.00
26D11568.001383.0012,951.00
27B420.00567.00987.00
28C983.002496.003,479.00
29Total12,971.004,446.0019,305.00
Sheet2
Cell Formulas
RangeFormula
D7=SUM(D5:D6)
D11=D10
D17=SUM(D14:D16)
D22=SUM(D20:D21)
D29=SUM(D26:D28)
E7=SUM(E5:E6)
E11=E10
E17=SUM(E14:E16)
E22=SUM(E20:E21)
E29=SUM(E26:E28)
P5=SUM(D5:O5)
P6=SUM(D6:O6)
P7=SUM(P5:P6)
P10=SUM(D10:O10)
P11=P10
P14=SUM(D14:O14)
P15=SUM(D15:O15)
P16=SUM(D16:O16)
P17=SUM(P14:P16)
P20=SUM(D20:N20)
P21=SUM(D21:N21)
P22=SUM(D22:N22)
P25=SUM(D25:O25)
P26=SUM(D26:O26)
P27=SUM(D27:O27)
P28=SUM(D28:O28)
P29=SUM(P25:P28)
F11=F10
G11=G10
H11=H10
I11=I10
J11=J10
K11=K10
L11=L10
M11=M10
N11=N10
O11=O10
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
Try this with data on sheet1 and results on sheet2.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG30Jan45
[COLOR="Navy"]Dim[/COLOR] Hds [COLOR="Navy"]As[/COLOR] Variant, Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] H [COLOR="Navy"]As[/COLOR] Variant
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")

[COLOR="Navy"]With[/COLOR] Sheets("sheet1")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
              Dic(Dn.Value).CompareMode = 1
        [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
            [COLOR="Navy"]End[/COLOR] If
              
              [COLOR="Navy"]If[/COLOR] Dn.Offset(, 3).Value = "Active" [COLOR="Navy"]Then[/COLOR]
                 [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).Exists(Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
                    
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 1).Value), Dn.Offset(, 2)
                 [COLOR="Navy"]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) + Dn.Offset(, 2)
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
'[COLOR="Green"][B]MsgBox Dic.Count[/B][/COLOR]
ReDim Ray(1 To Dic.Count * 100, 1 To UBound(Hds) + 1)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
   c = c + 1
   Ray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(K).keys
        Ray(c, 2) = p
            
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Hds)
                Ray(1, n + 1) = Hds(n)
                  
                  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(K)(p).keys
                        [COLOR="Navy"]If[/COLOR] Hds(n) = G [COLOR="Navy"]Then[/COLOR]
                        Ray(c, n + 1) = Dic(K)(p).Item(G)
                        [COLOR="Navy"]End[/COLOR] If
                   [COLOR="Navy"]Next[/COLOR] G
            [COLOR="Navy"]Next[/COLOR] n
     c = c + 1
     [COLOR="Navy"]Next[/COLOR] p
c = c + 2
[COLOR="Navy"]Next[/COLOR] K
Sheets("Sheet2").Range("A1").Resize(c, 15).Value = Ray
Totals
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] Totals()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, hTot [COLOR="Navy"]As[/COLOR] Double, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vSum [COLOR="Navy"]As[/COLOR] Double, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, Tot [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
   
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
     [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn
      [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Rw = Rng.Rows.Count + 3
.Cells(Rw + 1, "A") = "Overall"
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
            Rw = Rw + 1
            
            .Cells(Rw, "B") = K
            [COLOR="Navy"]For[/COLOR] n = 1 To 12
                Tot = Application.Sum(Dic(K).Offset(, n))
                .Cells(Rw, "B").Offset(, n) = IIf(Tot = 0, "", Tot)
             [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]For[/COLOR] n = 1 To 12
            [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Offset(, n)) [COLOR="Navy"]Then[/COLOR]
                hTot = hTot + Dn.Offset(, n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        Dn.Offset(, 13) = IIf(hTot = 0, "", hTot)
        hTot = 0
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Set[/COLOR] Rng1 = Rng.SpecialCells(xlCellTypeConstants)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng1.Areas
        Dn(Dn.Count).Offset(1).Value = "Totals"
            [COLOR="Navy"]For[/COLOR] n = 1 To 13
                vSum = Application.Sum(Dn.Offset(, n))
                Dn(Dn.Count).Offset(1, n) = IIf(vSum = 0, "", vSum)
            [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn

    Rng.Offset(-1, -1).Resize(Rng.Rows.Count + 2, 15).Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thank you Mick. The functionality is working fine on the sample sheet. However i had to insert a couple of columns inbetween to bring some more details.

So the data moved to a further column, as shown below. I tried adjusting the columns on the code, but i failed. Could you please help.

Also can you point me to changes to be done if i have to make similar tables (like the ones based on Unit) in Sheet 2, based on Sub-Unit / Market where should be the changes.


Book1
ABCDEFGHIJK
1CategoryUnitSub UnitSub-Unit 2MarketMarket UnitYearPeriodDataCorporateKPI Lifecycle
2AXP01345Active
3AXP01678Active
4AYP0232Mature
5BZP02567Active
6BZP0166Active
7BZP01-90Active
8CXP02100Active
9DYP0111223Active
10AXP02865Active
11AYP01124Mature
12CZP02674Active
13CZP02742Active
14CZP01983Active
15DWP01345Active
16DWP02742Active
17DWP02641Active
18AXP01578Not Applicable
19BYP01444Active
20CYP02980Active
Sheet1
Cell Formulas
RangeFormula
A1Category
A2A
A3A
A4A
A5B
A6B
A7B
A8C
A9D
A10A
A11A
A12C
A13C
A14C
A15D
A16D
A17D
A18A
A19B
A20C
B1Unit
B2X
B3X
B4Y
B5Z
B6Z
B7Z
B8X
B9Y
B10X
B11Y
B12Z
B13Z
B14Z
B15W
B16W
B17W
B18X
B19Y
B20Y
C1Sub Unit
D1Sub-Unit 2
E1Market
F1Market Unit
G1Year
H1Period
H2P01
H3P01
H4P02
H5P02
H6P01
H7P01
H8P02
H9P01
H10P02
H11P01
H12P02
H13P02
H14P01
H15P01
H16P02
H17P02
H18P01
H19P01
H20P02
I1Data
I2345
I3678
I432
I5567
I666
I7-90
I8100
I911223
I10865
I11124
I12674
I13742
I14983
I15345
I16742
I17641
I18578
I19444
I20980
J1Corporate
K1KPI Lifecycle
K2Active
K3Active
K4Mature
K5Active
K6Active
K7Active
K8Active
K9Active
K10Active
K11Mature
K12Active
K13Active
K14Active
K15Active
K16Active
K17Active
K18Not Applicable
K19Active
K20Active



MickG said:
Try this with data on sheet1 and results on sheet2.
Code: 
[COLOR=Navy]Sub[/COLOR] MG30Jan45
[COLOR=Navy]Dim[/COLOR] Hds [COLOR=Navy]As[/COLOR] Variant, Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, K [COLOR=Navy]As[/COLOR] Variant, p [COLOR=Navy]As[/COLOR] Variant, G [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Q [COLOR=Navy]As[/COLOR] Variant, Ray [COLOR=Navy]As[/COLOR] Variant, Dic [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Dim[/COLOR] Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] H [COLOR=Navy]As[/COLOR] Variant
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")

[COLOR=Navy]With[/COLOR] Sheets("sheet1")
[COLOR=Navy]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR=Navy]End[/COLOR] With

[COLOR=Navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
            [COLOR=Navy]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
              Dic(Dn.Value).CompareMode = 1
        [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, -1).Value) [COLOR=Navy]Then[/COLOR]
                [COLOR=Navy]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
            [COLOR=Navy]End[/COLOR] If
              
              [COLOR=Navy]If[/COLOR] Dn.Offset(, 3).Value = "Active" [COLOR=Navy]Then[/COLOR]
                 [COLOR=Navy]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).Exists(Dn.Offset(, 1).Value) [COLOR=Navy]Then[/COLOR]
                    
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 1).Value), Dn.Offset(, 2)
                 [COLOR=Navy]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) + Dn.Offset(, 2)
                [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Dn
'[COLOR=Green][B]MsgBox Dic.Count[/B][/COLOR]
ReDim Ray(1 To Dic.Count * 100, 1 To UBound(Hds) + 1)
c = 1
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.keys
   c = c + 1
   Ray(c, 1) = K
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] p [COLOR=Navy]In[/COLOR] Dic(K).keys
        Ray(c, 2) = p
            
            [COLOR=Navy]For[/COLOR] n = 0 To UBound(Hds)
                Ray(1, n + 1) = Hds(n)
                  
                  [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] G [COLOR=Navy]In[/COLOR] Dic(K)(p).keys
                        [COLOR=Navy]If[/COLOR] Hds(n) = G [COLOR=Navy]Then[/COLOR]
                        Ray(c, n + 1) = Dic(K)(p).Item(G)
                        [COLOR=Navy]End[/COLOR] If
                   [COLOR=Navy]Next[/COLOR] G
            [COLOR=Navy]Next[/COLOR] n
     c = c + 1
     [COLOR=Navy]Next[/COLOR] p
c = c + 2
[COLOR=Navy]Next[/COLOR] K
Sheets("Sheet2").Range("A1").Resize(c, 15).Value = Ray
Totals
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
[COLOR=Navy]Sub[/COLOR] Totals()
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, hTot [COLOR=Navy]As[/COLOR] Double, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] vSum [COLOR=Navy]As[/COLOR] Double, Rw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Rng1 [COLOR=Navy]As[/COLOR] Range, Dic [COLOR=Navy]As[/COLOR] Object, K [COLOR=Navy]As[/COLOR] Variant, Tot [COLOR=Navy]As[/COLOR] Double
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR=Navy]With[/COLOR] Sheets("Sheet2")
[COLOR=Navy]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
   
   [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
     [COLOR=Navy]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR=Navy]Then[/COLOR]
      [COLOR=Navy]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        Dic.Add Dn.Value, Dn
      [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
      [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
Rw = Rng.Rows.Count + 3
.Cells(Rw + 1, "A") = "Overall"
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.keys
            Rw = Rw + 1
            
            .Cells(Rw, "B") = K
            [COLOR=Navy]For[/COLOR] n = 1 To 12
                Tot = Application.Sum(Dic(K).Offset(, n))
                .Cells(Rw, "B").Offset(, n) = IIf(Tot = 0, "", Tot)
             [COLOR=Navy]Next[/COLOR] n
    [COLOR=Navy]Next[/COLOR] K
[COLOR=Navy]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        [COLOR=Navy]For[/COLOR] n = 1 To 12
            [COLOR=Navy]If[/COLOR] Not IsEmpty(Dn.Offset(, n)) [COLOR=Navy]Then[/COLOR]
                hTot = hTot + Dn.Offset(, n)
            [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] n
        Dn.Offset(, 13) = IIf(hTot = 0, "", hTot)
        hTot = 0
[COLOR=Navy]Next[/COLOR] Dn

[COLOR=Navy]Set[/COLOR] Rng1 = Rng.SpecialCells(xlCellTypeConstants)
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng1.Areas
        Dn(Dn.Count).Offset(1).Value = "Totals"
            [COLOR=Navy]For[/COLOR] n = 1 To 13
                vSum = Application.Sum(Dn.Offset(, n))
                Dn(Dn.Count).Offset(1, n) = IIf(vSum = 0, "", vSum)
            [COLOR=Navy]Next[/COLOR] n
    [COLOR=Navy]Next[/COLOR] Dn

    Rng.Offset(-1, -1).Resize(Rng.Rows.Count + 2, 15).Borders.Weight = 2
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
Try this for data with added columns (as Thread #3 )

Difficult to say how to modify code for similar data , it depended on the Data and Outcome required.
You would need to send an example of data and expected result.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG31Jan41
[COLOR="Navy"]Dim[/COLOR] Hds [COLOR="Navy"]As[/COLOR] Variant, Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] H [COLOR="Navy"]As[/COLOR] Variant
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")

[COLOR="Navy"]With[/COLOR] Sheets("sheet1")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
              Dic(Dn.Value).CompareMode = 1
        [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
            [COLOR="Navy"]End[/COLOR] If
              
              [COLOR="Navy"]If[/COLOR] Dn.Offset(, 9).Value = "Active" [COLOR="Navy"]Then[/COLOR]
                 [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).Exists(Dn.Offset(, 6).Value) [COLOR="Navy"]Then[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 6).Value), Dn.Offset(, 7)
                 [COLOR="Navy"]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 6).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 6).Value) + Dn.Offset(, 7)
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn

ReDim Ray(1 To Dic.Count * 100, 1 To UBound(Hds) + 1)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
   c = c + 1
   Ray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(K).keys
        Ray(c, 2) = p
            
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Hds)
                Ray(1, n + 1) = Hds(n)
                  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(K)(p).keys
                        [COLOR="Navy"]If[/COLOR] Hds(n) = G [COLOR="Navy"]Then[/COLOR]
                        Ray(c, n + 1) = Dic(K)(p).Item(G)
                        [COLOR="Navy"]End[/COLOR] If
                   [COLOR="Navy"]Next[/COLOR] G
            [COLOR="Navy"]Next[/COLOR] n
     c = c + 1
     [COLOR="Navy"]Next[/COLOR] p
c = c + 2
[COLOR="Navy"]Next[/COLOR] K
Sheets("Sheet2").Range("A1").Resize(c, 15).Value = Ray
Totals
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] Totals()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, hTot [COLOR="Navy"]As[/COLOR] Double, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vSum [COLOR="Navy"]As[/COLOR] Double, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, Tot [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
   [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(, 15)
      .Interior.Color = 6299648
      .Font.Color = 16777215
   [COLOR="Navy"]End[/COLOR] With
   
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
     [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn
      [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

Rw = Rng.Rows.Count + 3
.Cells(Rw + 1, "A") = "Overall"
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
            Rw = Rw + 1
            .Cells(Rw, "B") = K
            
            [COLOR="Navy"]For[/COLOR] n = 1 To 12
                Tot = Application.Sum(Dic(K).Offset(, n))
                .Cells(Rw, "B").Offset(, n) = IIf(Tot = 0, "", Tot)
             [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]For[/COLOR] n = 1 To 12
            [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Offset(, n)) [COLOR="Navy"]Then[/COLOR]
                hTot = hTot + Dn.Offset(, n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        Dn.Offset(, 13) = IIf(hTot = 0, "", hTot)
        hTot = 0
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Set[/COLOR] Rng1 = Rng.SpecialCells(xlCellTypeConstants)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng1.Areas
        Dn(Dn.Count).Offset(1).Value = "Totals"
        [COLOR="Navy"]With[/COLOR] Dn(Dn.Count).Offset(1).Resize(, 14)
            .Interior.Color = 7434613
            .Font.Color = 16777215
        [COLOR="Navy"]End[/COLOR] With
        Dn(Dn.Count).Offset(1).Interior.Color = 6299648

            [COLOR="Navy"]For[/COLOR] n = 1 To 13
                vSum = Application.Sum(Dn.Offset(, n))
                Dn(Dn.Count).Offset(1, n) = IIf(vSum = 0, "", vSum)
            [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn

    [COLOR="Navy"]With[/COLOR] Rng.Offset(-1, -1).Resize(Rng.Rows.Count + 2, 15)
        .Borders.Weight = 2
      .HorizontalAlignment = xlCenter
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks a Ton Mick.. this works perfectly. There is jus 1 minimal issue, which i have addressed below.

For the below Table, Category A should not be shown in the output table as it is not Active. But currently it is being shown.


Book1
ABCDEFGHIJK
1CategoryUnitSub UnitSub-Unit 2MarketMarket UnitYearPeriodDataCorporateKPI Lifecycle
4AYP0232Mature
9DYP0111223Active
11AYP01124Mature
19BYP01444Active
20CYP02980Active
Sheet1
Cell Formulas
RangeFormula
A1Category
A2A
A3A
A4A
A5B
A6B
A7B
A8C
A9D
A10A
A11A
A12C
A13C
A14C
A15D
A16D
A17D
A18A
A19B
A20C
B1Unit
B2X
B3X
B4Y
B5Z
B6Z
B7Z
B8X
B9Y
B10X
B11Y
B12Z
B13Z
B14Z
B15W
B16W
B17W
B18X
B19Y
B20Y
C1Sub Unit
D1Sub-Unit 2
E1Market
F1Market Unit
G1Year
H1Period
H2P01
H3P01
H4P02
H5P02
H6P01
H7P01
H8P02
H9P01
H10P02
H11P01
H12P02
H13P02
H14P01
H15P01
H16P02
H17P02
H18P01
H19P01
H20P02
I1Data
I2345
I3678
I432
I5567
I666
I7-90
I8100
I911223
I10865
I11124
I12674
I13742
I14983
I15345
I16742
I17641
I18578
I19444
I20980
J1Corporate
K1KPI Lifecycle
K2Active
K3Active
K4Mature
K5Active
K6Active
K7Active
K8Active
K9Active
K10Active
K11Mature
K12Active
K13Active
K14Active
K15Active
K16Active
K17Active
K18Not Applicable
K19Active
K20Active




Book1
ABCDEFGHIJKLMNO
7YA
8D1122311223
9B444444
10C980980
11Totals1166798012647
Sheet2
Cell Formulas
RangeFormula
A7Y
B7A
B8D
B9B
B10C
B11Totals
C811223
C9444
C1111667
O811223
O9444
O10980
O1112647
D10980
D11980


For the sub-units, i need a similar out put only.. sample data and output is pasted in the below reply.
 
Upvote 0
Data for sub units & Markets


Book1
ABCDEFGHIJK
1CategoryUnitSub UnitSub-Unit 2MarketMarket UnitYearPeriodDataCorporateKPI Lifecycle
2AXqqP01345Active
3AXqqP01678Active
4AYP0232Mature
5BZMark1P02567Active
6BZMark1P0166Active
7BZMark2P01-90Active
8CXwwP02100Active
9DYP0111223Active
10AXwwP02865Mature
11AYP01124Mature
12CZMark1P02674Active
13CZMark2P02742Active
14CZMark2P01983Active
15DWP01345Active
16DWP02742Active
17DWP02641Active
18AXqqP01578Not Applicable
19BYP01444Active
20CYP02980Active
Sheet1
Cell Formulas
RangeFormula
A1Category
A2A
A3A
A4A
A5B
A6B
A7B
A8C
A9D
A10A
A11A
A12C
A13C
A14C
A15D
A16D
A17D
A18A
A19B
A20C
B1Unit
B2X
B3X
B4Y
B5Z
B6Z
B7Z
B8X
B9Y
B10X
B11Y
B12Z
B13Z
B14Z
B15W
B16W
B17W
B18X
B19Y
B20Y
C1Sub Unit
C2qq
C3qq
C8ww
C10ww
C18qq
D1Sub-Unit 2
E1Market
E5Mark1
E6Mark1
E7Mark2
E12Mark1
E13Mark2
E14Mark2
F1Market Unit
G1Year
H1Period
H2P01
H3P01
H4P02
H5P02
H6P01
H7P01
H8P02
H9P01
H10P02
H11P01
H12P02
H13P02
H14P01
H15P01
H16P02
H17P02
H18P01
H19P01
H20P02
I1Data
I2345
I3678
I432
I5567
I666
I7-90
I8100
I911223
I10865
I11124
I12674
I13742
I14983
I15345
I16742
I17641
I18578
I19444
I20980
J1Corporate
K1KPI Lifecycle
K2Active
K3Active
K4Mature
K5Active
K6Active
K7Active
K8Active
K9Active
K10Mature
K11Mature
K12Active
K13Active
K14Active
K15Active
K16Active
K17Active
K18Not Applicable
K19Active
K20Active


Output, To come below the unit tables.


Book1
BCDEFGHIJKLMNOP
4MarketCategoryP01P02P03P04P05P06P07P08P09P10P11P12Total
5mark1B66.00567.00633.00
6C674.00674.00
766.001,241.00
8
9
10
11
12
13
14mark 2B-90.00-90.00
15C983.001416.002,399.00
16893.001,416.00
17
18Sub-Unit
19qqA1,023.001,023.00
201,023.00
21
22
23wwC100.00100.00
24100.00
Sheet4
Cell Formulas
RangeFormula
P5=SUM(D5:O5)
P6=SUM(D6:O6)
P14=SUM(D14:O14)
P15=SUM(D15:O15)
D7=SUM(D5:D6)
D16=SUM(D14:D15)
E7=SUM(E5:E6)
E16=SUM(E14:E15)
 
Upvote 0
Update for thread #5 .
Code: 
[COLOR="Navy"]Sub[/COLOR] MG01Feb13
[COLOR="Navy"]Dim[/COLOR] Hds [COLOR="Navy"]As[/COLOR] Variant, Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] H [COLOR="Navy"]As[/COLOR] Variant
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")

[COLOR="Navy"]With[/COLOR] Sheets("sheet1")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn.Offset(, 9).Value = "Active" [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
              Dic(Dn.Value).CompareMode = 1
        [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
            [COLOR="Navy"]End[/COLOR] If
              [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).Exists(Dn.Offset(, 6).Value) [COLOR="Navy"]Then[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 6).Value), Dn.Offset(, 7)
                 [COLOR="Navy"]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 6).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 6).Value) + Dn.Offset(, 7)
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn

ReDim Ray(1 To Dic.Count * 100, 1 To UBound(Hds) + 1)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
   c = c + 1
   Ray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(K).keys
        Ray(c, 2) = p
            
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Hds)
                Ray(1, n + 1) = Hds(n)
                  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(K)(p).keys
                        [COLOR="Navy"]If[/COLOR] Hds(n) = G [COLOR="Navy"]Then[/COLOR]
                        Ray(c, n + 1) = Dic(K)(p).Item(G)
                        [COLOR="Navy"]End[/COLOR] If
                   [COLOR="Navy"]Next[/COLOR] G
            [COLOR="Navy"]Next[/COLOR] n
     c = c + 1
     [COLOR="Navy"]Next[/COLOR] p
c = c + 2
[COLOR="Navy"]Next[/COLOR] K
 Sheets("Sheet2").Columns("A:O").Clear
 Sheets("Sheet2").Range("A1").Resize(c, 15).Value = Ray
Totals
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] Totals()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, hTot [COLOR="Navy"]As[/COLOR] Double, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vSum [COLOR="Navy"]As[/COLOR] Double, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, Tot [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
   [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(, 15)
      .Interior.Color = 6299648
      .Font.Color = 16777215
   [COLOR="Navy"]End[/COLOR] With
   
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
     [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn
      [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

Rw = Rng.Rows.Count + 3
.Cells(Rw + 1, "A") = "Overall"
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
            Rw = Rw + 1
            .Cells(Rw, "B") = K
            
            [COLOR="Navy"]For[/COLOR] n = 1 To 12
                Tot = Application.Sum(Dic(K).Offset(, n))
                .Cells(Rw, "B").Offset(, n) = IIf(Tot = 0, "", Tot)
             [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]For[/COLOR] n = 1 To 12
            [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Offset(, n)) [COLOR="Navy"]Then[/COLOR]
                hTot = hTot + Dn.Offset(, n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        Dn.Offset(, 13) = IIf(hTot = 0, "", hTot)
        hTot = 0
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Set[/COLOR] Rng1 = Rng.SpecialCells(xlCellTypeConstants)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng1.Areas
        Dn(Dn.Count).Offset(1).Value = "Totals"
        [COLOR="Navy"]With[/COLOR] Dn(Dn.Count).Offset(1).Resize(, 14)
            .Interior.Color = 7434613
            .Font.Color = 16777215
        [COLOR="Navy"]End[/COLOR] With
        Dn(Dn.Count).Offset(1).Interior.Color = 6299648

            [COLOR="Navy"]For[/COLOR] n = 1 To 13
                vSum = Application.Sum(Dn.Offset(, n))
                Dn(Dn.Count).Offset(1, n) = IIf(vSum = 0, "", vSum)
            [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn

    [COLOR="Navy"]With[/COLOR] Rng.Offset(-1, -1).Resize(Rng.Rows.Count + 2, 15)
        .Borders.Weight = 2
      .HorizontalAlignment = xlCenter
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Try this for Post number #7 results on sheet2.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG01Feb57
[COLOR="Navy"]Dim[/COLOR] Hds [COLOR="Navy"]As[/COLOR] Variant, Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object, RngB [COLOR="Navy"]As[/COLOR] Range, Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] H [COLOR="Navy"]As[/COLOR] Variant, Cols [COLOR="Navy"]As[/COLOR] Variant, Cl [COLOR="Navy"]As[/COLOR] Variant
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")
Cols = Array(2, 5, 3)

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Cl [COLOR="Navy"]In[/COLOR] Cols
[COLOR="Navy"]With[/COLOR] Sheets("sheet1")
[COLOR="Navy"]Set[/COLOR] Rng = .Range(.Cells(2, Cl), Cells(Rows.Count, Cl).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
      [COLOR="Navy"]If[/COLOR] .Cells(Dn.Row, "K").Value = "Active" And Dn.Value <> "" [COLOR="Navy"]Then[/COLOR]
         [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
              Dic(Dn.Value).CompareMode = 1
        [COLOR="Navy"]End[/COLOR] If
            
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Exists(.Cells(Dn.Row, "A").Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value)(.Cells(Dn.Row, "A").Value) = CreateObject("Scripting.Dictionary")
                    Dic(Dn.Value)(.Cells(Dn.Row, "A").Value).CompareMode = 1
            [COLOR="Navy"]End[/COLOR] If
              [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value)(.Cells(Dn.Row, "A").Value).Exists(.Cells(Dn.Row, "H").Value) [COLOR="Navy"]Then[/COLOR]
                    Dic(Dn.Value)(.Cells(Dn.Row, "A").Value).Add (.Cells(Dn.Row, "H").Value), .Cells(Dn.Row, "I").Value
                 [COLOR="Navy"]Else[/COLOR]
                    Dic(Dn.Value)(.Cells(Dn.Row, "A").Value).Item(.Cells(Dn.Row, "H").Value) = _
                    Dic(Dn.Value)(.Cells(Dn.Row, "A").Value).Item(.Cells(Dn.Row, "H").Value) + .Cells(Dn.Row, "I").Value
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn

ReDim Ray(1 To 100, 1 To UBound(Hds) + 1)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
   c = c + 1
   Ray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(K).keys
        Ray(c, 2) = p
            
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Hds)
               [COLOR="Navy"]If[/COLOR] n = 0 [COLOR="Navy"]Then[/COLOR] Hds(n) = .Cells(1, Cl)
                Ray(1, n + 1) = Hds(n)
                  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(K)(p).keys
                        [COLOR="Navy"]If[/COLOR] Hds(n) = G [COLOR="Navy"]Then[/COLOR]
                        Ray(c, n + 1) = Dic(K)(p).Item(G)
                        [COLOR="Navy"]End[/COLOR] If
                   [COLOR="Navy"]Next[/COLOR] G
            [COLOR="Navy"]Next[/COLOR] n
     c = c + 1
     [COLOR="Navy"]Next[/COLOR] p
c = c + 2
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]If[/COLOR] Cl = 2 [COLOR="Navy"]Then[/COLOR]
        .Columns("A:O").Clear
        .Range("A1").Resize(c, 15).Value = Ray
    [COLOR="Navy"]Else[/COLOR]
        Lst = .Range("B" & Rows.Count).End(xlUp).Row
        .Range("A" & Lst + 3).Resize(c, 15).Value = Ray
       
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
Totals Lst + 3, Cl, Dic.Count
[COLOR="Navy"]Next[/COLOR] Cl



[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] Totals(temp, m, num)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, hTot [COLOR="Navy"]As[/COLOR] Double, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vSum [COLOR="Navy"]As[/COLOR] Double, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, Tot [COLOR="Navy"]As[/COLOR] Double, Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Tp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]If[/COLOR] num > 0 [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]If[/COLOR] temp = 2 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Rng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Rng = .Range("B" & temp + 1, .Range("B" & Rows.Count).End(xlUp))
    [COLOR="Navy"]End[/COLOR] If
Lst = Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Row

   
   
   [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(, 15)
      .Interior.Color = 6299648
      .Font.Color = 16777215
   [COLOR="Navy"]End[/COLOR] With
   
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
     [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn
      [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]If[/COLOR] m = 2 [COLOR="Navy"]Then[/COLOR]
  Rw = Rng.Rows.Count + 6
  .Cells(Rw + 1, "A") = "Overall"
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
            Rw = Rw + 1
            .Cells(Rw, "B") = K
            
            [COLOR="Navy"]For[/COLOR] n = 1 To 12
                Tot = Application.Sum(Dic(K).Offset(, n))
                .Cells(Rw, "B").Offset(, n) = IIf(Tot = 0, "", Tot)
             [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] K
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] If
   
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]For[/COLOR] n = 1 To 12
            [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Offset(, n)) [COLOR="Navy"]Then[/COLOR]
                hTot = hTot + Dn.Offset(, n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        Dn.Offset(, 13) = IIf(hTot = 0, "", hTot)
        hTot = 0
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Set[/COLOR] Rng1 = Rng.SpecialCells(xlCellTypeConstants)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng1.Areas
        Dn(Dn.Count).Offset(1).Value = "Totals"
        [COLOR="Navy"]With[/COLOR] Dn(Dn.Count).Offset(1).Resize(, 14)
            .Interior.Color = 7434613
            .Font.Color = 16777215
        [COLOR="Navy"]End[/COLOR] With
        Dn(Dn.Count).Offset(1).Interior.Color = 6299648

            [COLOR="Navy"]For[/COLOR] n = 1 To 13
                vSum = Application.Sum(Dn.Offset(, n))
                Dn(Dn.Count).Offset(1, n) = IIf(vSum = 0, "", vSum)
            [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn

    [COLOR="Navy"]With[/COLOR] Rng.Offset(-1, -1).Resize(Rng.Rows.Count + 2, 15)
        .Borders.Weight = 2
        .HorizontalAlignment = xlCenter
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
HI,

I am gettinf Application Defined or Object Defined Error on this line.

Set Rng = .Range(.Cells(2, Cl), Cells(Rows.Count, Cl).End(xlUp))

Thanks,
nitya
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
RAINFALL CESSATION DATE USING INDEX
Replies
1
Views
237
Thlama
T
D
  • Question Question
Scoring weighted permutations
Replies
1
Views
219
StephenCrump
S
D
  • Question Question
VBA to Export Tab to .CSV with date
Replies
1
Views
220
abdelfattah
A
P
  • Solved
Lookup based on multiple criteria
2 3
Replies
22
Views
901
paulkc
P
M
  • Solved
Move row data left right.
Replies
7
Views
390
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

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