Data to be processed using VB Macro

Nitya0808

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

There is a set of data in sheet 1.

CategoryUnitPeriodDataLifecycle

<tbody>
</tbody>


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


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
 
Try this in sheet 2, for data from sheet 3 to columns "Q,R,S & T in sheet 2.
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Feb34
[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] Rw [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, sLst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")
Cols = Array(2, 5, 3)
  ReDim Nums(1 To UBound(Cols) + 1)
   sLst = 6
   Columns("S:S").ClearContents
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Cl [COLOR="Navy"]In[/COLOR] Cols
[COLOR="Navy"]With[/COLOR] Sheets("sheet3")
[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

[COLOR="Navy"]Dim[/COLOR] Tot [COLOR="Navy"]As[/COLOR] Double, R [COLOR="Navy"]As[/COLOR] Range, nTot [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] TotRng [COLOR="Navy"]As[/COLOR] Range, CopyRng [COLOR="Navy"]As[/COLOR] Range
ReDim Ray(1 To 100, 1 To UBound(Hds) + 1)

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]Set[/COLOR] CopyRng = .Range("A5", Range("A" & Rows.Count).End(xlUp))
    CopyRng.Resize(, 2).Copy Range("Q5")
    [COLOR="Navy"]Set[/COLOR] TotRng = .Range("R" & sLst, Range("R" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] TotRng.Areas
    
    [COLOR="Navy"]If[/COLOR] Dn.Count > 1 [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Dn = Dn.Resize(Dn.Count - 1)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn
            Tot = 0
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
                temp = IIf(R.Offset(, -1) = "", temp, R.Offset(, -1))
                [COLOR="Navy"]If[/COLOR] temp = K [COLOR="Navy"]Then[/COLOR]
                    
                    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(K).keys
                        [COLOR="Navy"]If[/COLOR] p = R.Value [COLOR="Navy"]Then[/COLOR]
                            [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Hds)
                                [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]
                                        Tot = Tot + Dic(K)(p).Item(G)
                                    [COLOR="Navy"]End[/COLOR] If
                                [COLOR="Navy"]Next[/COLOR] G
                            [COLOR="Navy"]Next[/COLOR] n
                        [COLOR="Navy"]End[/COLOR] If
                     [COLOR="Navy"]Next[/COLOR] p
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] K

R.Offset(, 1) = IIf(Tot = 0, "", Tot)
R.Offset(, 2) = IIf(Tot = 0, "", (Tot / 12) * Sheets("Sheet2").Range("H2").Value)

        [COLOR="Navy"]Next[/COLOR] R

[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With

sLst = Range("S" & Rows.Count).End(xlUp).Row + 3
[COLOR="Navy"]Next[/COLOR] Cl
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Thanks Mick. Below are the observations.

- Since the older code to copy from Sheet 1, is putting data from A1, the first few rows are missed. How to edit the previous code to display output from A5 instead of A1.

- The code works fine for All the tables except overall part of it. The KPI names are shown but sum of P01-P12 data is not displayed.

-T column is only showing as 0.0 at all places.

Thanks

Try this in sheet 2, for data from sheet 3 to columns "Q,R,S & T in sheet 2.
Code:
[COLOR=Navy]Sub[/COLOR] MG05Feb34
[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] Rw [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, sLst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
Hds = Array("Unit", "Category", "P01", "P02", "P03", "P04", "P05", "P06", "P07", "P08", "P09", "P10", "P11", "P12", "Total")
Cols = Array(2, 5, 3)
  ReDim Nums(1 To UBound(Cols) + 1)
   sLst = 6
   Columns("S:S").ClearContents
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Cl [COLOR=Navy]In[/COLOR] Cols
[COLOR=Navy]With[/COLOR] Sheets("sheet3")
[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

[COLOR=Navy]Dim[/COLOR] Tot [COLOR=Navy]As[/COLOR] Double, R [COLOR=Navy]As[/COLOR] Range, nTot [COLOR=Navy]As[/COLOR] Double
[COLOR=Navy]Dim[/COLOR] TotRng [COLOR=Navy]As[/COLOR] Range, CopyRng [COLOR=Navy]As[/COLOR] Range
ReDim Ray(1 To 100, 1 To UBound(Hds) + 1)

[COLOR=Navy]With[/COLOR] Sheets("Sheet2")
    [COLOR=Navy]Set[/COLOR] CopyRng = .Range("A5", Range("A" & Rows.Count).End(xlUp))
    CopyRng.Resize(, 2).Copy Range("Q5")
    [COLOR=Navy]Set[/COLOR] TotRng = .Range("R" & sLst, Range("R" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
[COLOR=Navy]End[/COLOR] With

[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] TotRng.Areas
    
    [COLOR=Navy]If[/COLOR] Dn.Count > 1 [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] Dn = Dn.Resize(Dn.Count - 1)
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Dn
            Tot = 0
            [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.keys
                temp = IIf(R.Offset(, -1) = "", temp, R.Offset(, -1))
                [COLOR=Navy]If[/COLOR] temp = K [COLOR=Navy]Then[/COLOR]
                    
                    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] p [COLOR=Navy]In[/COLOR] Dic(K).keys
                        [COLOR=Navy]If[/COLOR] p = R.Value [COLOR=Navy]Then[/COLOR]
                            [COLOR=Navy]For[/COLOR] n = 2 To UBound(Hds)
                                [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]
                                        Tot = Tot + Dic(K)(p).Item(G)
                                    [COLOR=Navy]End[/COLOR] If
                                [COLOR=Navy]Next[/COLOR] G
                            [COLOR=Navy]Next[/COLOR] n
                        [COLOR=Navy]End[/COLOR] If
                     [COLOR=Navy]Next[/COLOR] p
                [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]Next[/COLOR] K

R.Offset(, 1) = IIf(Tot = 0, "", Tot)
R.Offset(, 2) = IIf(Tot = 0, "", (Tot / 12) * Sheets("Sheet2").Range("H2").Value)

        [COLOR=Navy]Next[/COLOR] R

[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]End[/COLOR] With

sLst = Range("S" & Rows.Count).End(xlUp).Row + 3
[COLOR=Navy]Next[/COLOR] Cl
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
The code is getting a bit out of Hand so I have done the following.
There is a code button (CODE(1)) in sheet 1 to produce results from Sheet1 to sheet4, using the basic code.
There is a code button (CODE(2)) in sheet 3 to produce Results from sheet 3 to sheet5, using the basic Code.

There are 2 Code buttons in sheet2, CODE(3) button is to produce the Basic Results from "Sheet4", columns "A to R"),
Code(4) button on sheet 2 Produces the Results in columns "S & T" based on the Data in Columns("Q & R") but relating to sheet5.

See example below:-
https://app.box.com/s/cbfxq813lvfe898793xgoomujztr9nvm
 
Upvote 0
Thanks Mick.. The code worked perfectly fine.

Now the last part is the calculation of Sheet 4 in my sample file. Please let me know if you need any clarifications on it.
 
Upvote 0
I can see how you have arrived at the results on sheet 4, except "AF6" value.
Please describe what you would like the code to do on sheet4 row 5 on, to achieve the required results.
 
Upvote 0
I can see how you have arrived at the results on sheet 4, except "AF6" value.
Please describe what you would like the code to do on sheet4 row 5 on, to achieve the required results.

The column AF6 will be hardcoded values put in the sheet. If we need to clear that sheet before updating values everytime, then we need to ensure we maintain the values in AF column. If we dont need to clear the sheet, then no worries.
 
Upvote 0
If the formatted cells shown in sheet 4 are always the same why can you not just leave them with the current formula.
As per my previous thread, I see what you have in Sheet 4 ,but I'm not sure of the methodology you require to achieve it.!!
 
Upvote 0
Hi Mick, its not that simple. i tried multiple formula method but was challenged. I would need the below functionality done by Code.

Reporting Period can be any number from 1 to 12. - This is the number in H2 of Cost View sheet

When Reporting Period is 1, Sheet 4 Column C will be Sheet 3 T6-O6,
When Reporting Period is 2, Sheet 4 Column D will be Sheet 3 T6-O6

This is a excel to be generated monthly through the year. The sheet 4 is the actual output.
 
Upvote 0
Perhaps this:-
Run in sheet4
Code:
[COLOR=navy]Sub[/COLOR] MG10Feb02
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Rng2 [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range("C6:n6")
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
     Rng([h2]) = .Range("V6") - .Range("O6")
     Rng([h2]).NumberFormat = """€""#,##0.00_);(""€""#,##0.00)"
     Rng(Rng.Count).Offset(, 1).Value = Application.Sum(Rng)
[COLOR=navy]End[/COLOR] With

[COLOR=navy]Set[/COLOR] Rng2 = Range("T6:AE6")

Rng2([h2]) = (Rng2(Rng2.Count).Offset(, 1) / 12) * [h2]
 
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0

Forum statistics

Threads
1,215,330
Messages
6,124,305
Members
449,150
Latest member
NyDarR

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