VBA Dictionary / Collection help for Sumifs Formula...

[Mallesh23]

Hi Team,

I have below Data and its expected output, Currently I am getting the result via Sumifs formula.
But I want answer using vba dictionary or Collections help to achieve same result.

Input Data is column (A:F)
Expected Output is in Column Range("H2:H5) and
Criteria is in Range("H13:J15)"

Step 1 Extract Unique value from Column "A" paste horizontally in Range("I2") onward(transpose it)
Step 2, Apply sumifs formula, Take Sum those columns which is mentioned infront of Cost Center.

Uploaded Screenshot as well.
Range("I3") FORMULA =SUMIFS($B$2:$B$20,$A$2:$A$20,I$2)+SUMIFS($C$2:$C$20,$A$2:$A$20,I$2)
Range("I4") FORMULA =SUMIFS($B$2:$B$20,$A$2:$A$20,I$2)+SUMIFS($C$2:$C$20,$A$2:$A$20,I$2)
Range("I5") FORMULA =SUMIFS($F$2:$F$20,$A$2:$A$20,I$2)


I understand vba code, I will modify as per my requirement later.

Cost Center Description	Basic	Arr Basic	City Compensatory Allowan	Arr CCA	H.R.A.			Cost Center Unique values horizontally Pasted
20009	111392.00​	657.00​	12353.00	201.00​	44557.00​		Cost Center Description	20009	20000	20003	20006
20000	73190.00​	584.00​	19265.00	160.00​	29276.00​		Basic	126620.00​	120639.00​	128036.00​	67594.00​
20003	91846.00​	595.00​	17111.00	645.00​	36739.00​		City Compensatory Allowan	24940.00​	54786.00​	29697.00​	31091.00​
20003	35146.00​	449.00​	11662.00	279.00​	14059.00​		H.R.A.	50157.00​	47720.00​	50798.00​	26871.00​
20006	16369.00​	197.00​	18970.00	68.00​	6548.00​
20005	29910.00​	174.00​	12230.00	126.00​	11964.00​		=SUMIFS($B$2:$B$20,$A$2:$A$20,I$2)+SUMIFS($C$2:$C$20,$A$2:$A$20,I$2)
20000	19095.00​	244.00​	18782.00	839.00​	7638.00​		=SUMIFS($D$2:$D$20,$A$2:$A$20,I$2)+SUMIFS($E$2:$E$20,$A$2:$A$20,I$2)
20007	39674.00​	528.00​	11525.00	578.00​	15870.00​		=SUMIFS($F$2:$F$20,$A$2:$A$20,I$2)
20001	13067.00​	605.00​	18795.00	103.00​	4303.00​
20002	35564.00​	395.00​	15402.00	789.00​	14226.00​		Criteria to Sum
20006	50807.00​	221.00​	11560.00	493.00​	20323.00​		Cost Center Description	Take sum of headers
20008	42818.00​	634.00​	11077.00	207.00​	17127.00​		Basic	Basic	Arr Basic
20005	45113.00​	412.00​	18777.00	316.00​	18046.00​		City Compensatory Allowan	City Compensatory Allowan	Arr CCA
20004	86064.00​	621.00​	12822.00	404.00​	34426.00​		H.R.A.	H.R.A.
20008	16388.00​	300.00​	13432.00	444.00​	6555.00​
20001	14000.00​	495.00​	15577.00	673.00​	5600.00​
20009	14000.00​	571.00​	11678.00	708.00​	5600.00​
20001	33419.00​	213.00​	12360.00	198.00​	13368.00​
20000	27014.00​	512.00​	15505.00	235.00​	10806.00​

I
Thanks in advance for your help!

Regards,
mg

 

[mse330]

Hi Mallesh23,

Try the below code

Sub test()

Dim a, b, aa$, bb$, cc$
a = [A1].CurrentRegion

With CreateObject("scripting.dictionary")
    For x = 2 To UBound(a)
        If Not .exists(a(x, 1)) Then
            .Add a(x, 1), Join(Array(a(x, 2) + a(x, 3), a(x, 4) + a(x, 5), a(x, 6)), "|")
        Else
            aa = a(x, 2) + a(x, 3) + Split(.Item(a(x, 1)), "|")(0)
            bb = a(x, 4) + a(x, 5) + Split(.Item(a(x, 1)), "|")(1)
            cc = a(x, 6) + Split(.Item(a(x, 1)), "|")(2)
            .Item(a(x, 1)) = Join(Array(aa, bb, cc), "|")
        End If
    Next
    ReDim b(1 To .Count, 1 To 4)
    For Each k In .keys
        i = i + 1
        b(i, 1) = k: b(i, 2) = Split(.Item(k), "|")(0)
        b(i, 3) = Split(.Item(k), "|")(1): b(i, 4) = Split(.Item(k), "|")(2)
    Next
End With

[H2].Resize(4) = [{"Cost Center Description";"Basic";"City Compensatory Allowan";"H.R.A."}]
[I2].Resize(UBound(b, 2), UBound(b)) = Application.Transpose(b)

End Sub

 

[DanteAmor]

So assuming your data in A2 onwards. The results in I2 onwards:

Dante Amor
	A	B	C	D	E	F			I	J	K	L	M	N	O	P	Q	R
1	Cost	Basic	Arr Basic	City	Arr CCA	H.R.A.			Cost
2	20009	111392.00	657.00	12353.00	201.00	44557.00			20009	20000	20003	20006	20005	20007	20001	20002	20008	20004
3	20000	73190.00	584.00	19265.00	160.00	29276.00			126620.00	120639.00	128036.00	67594.00	75609.00	40202.00	61799.00	35959.00	60140.00	86685.00
4	20003	91846.00	595.00	17111.00	645.00	36739.00			24940.00	54786.00	29697.00	31091.00	31449.00	12103.00	47706.00	16191.00	25160.00	13226.00
5	20003	35146.00	449.00	11662.00	279.00	14059.00			50157.00	47720.00	50798.00	26871.00	30010.00	15870.00	23271.00	14226.00	23682.00	34426.00
6	20006	16369.00	197.00	18970.00	68.00	6548.00
7	20005	29910.00	174.00	12230.00	126.00	11964.00
8	20000	19095.00	244.00	18782.00	839.00	7638.00
9	20007	39674.00	528.00	11525.00	578.00	15870.00
10	20001	13067.00	605.00	18795.00	103.00	4303.00
11	20002	35564.00	395.00	15402.00	789.00	14226.00
12	20006	50807.00	221.00	11560.00	493.00	20323.00
13	20008	42818.00	634.00	11077.00	207.00	17127.00
14	20005	45113.00	412.00	18777.00	316.00	18046.00
15	20004	86064.00	621.00	12822.00	404.00	34426.00
16	20008	16388.00	300.00	13432.00	444.00	6555.00
17	20001	14000.00	495.00	15577.00	673.00	5600.00
18	20009	14000.00	571.00	11678.00	708.00	5600.00
19	20001	33419.00	213.00	12360.00	198.00	13368.00
20	20000	27014.00	512.00	15505.00	235.00	10806.00
Hoja6

Try:

Sub VBA_Sumifs()
  Dim a As Variant, b As Variant, dic As Object
  Dim i As Long, lr As Long, m As Long, n As Long, col As Long
  '
  lr = Range("A" & Rows.Count).End(3).Row
  n = Evaluate("=SUM(IF(FREQUENCY(MATCH(A2:A" & lr & ",A2:A" & lr & ",0)," & _
                                 "MATCH(A2:A" & lr & ",A2:A" & lr & ",0))>0,1))")
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:F" & lr).Value2
  ReDim b(1 To 3, 1 To n)
  '
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      m = m + 1
      dic(a(i, 1)) = m
      col = m
    Else
      col = dic(a(i, 1))
    End If
    b(1, col) = b(1, col) + a(i, 2) + a(i, 3)
    b(2, col) = b(2, col) + a(i, 4) + a(i, 5)
    b(3, col) = b(3, col) + a(i, 6)
  Next
  '
  Range("I2").Resize(1, dic.Count).Value = dic.keys
  Range("I3").Resize(3, n).Value = b
End Sub

 

[Mallesh23]

Hi mse300 and Danteamor,

Thank you both of you for your help on this.
Danteamor your code is working fine giving expected result.
To sum Basic, Macro to find Which columns to sum in Criteria List. and find those columns and sum only those columns.


b(1, col) = b(1, col) + a(i, 2) + a(i, 3)
= b(1, col) = b(1, col) + a(i, Col_Basics) + a(i, Col_Arr Basics) something like this.


I am ok with normal loop also and if conditions. Thanks.



Criteria:-

Cost Description	Columns	Columns
Basic	Basic	Arr Basic
City Allowance	City	Arr CCA
HRA	H.R.A.

Thanks in advance
Regards,
mg

 

[mse330]

Hi Mallesh23,

Thanks for the feedback ... I think you could achieve the same in a simpler way using your own formulas which would also be easier for you to miniplate at a later stage if required. Just one more way if interested, let us know if you have any question

Sub RetainFormulas()

Dim a: a = [A1].CurrentRegion

With CreateObject("scripting.dictionary")
    For x = 2 To UBound(a)
        If Not .exists(a(x, 1)) Then .Add a(x, 1), Nothing
    Next
    [I2].Resize(, .Count) = .keys
    [I3].Resize(, .Count) = Replace("=SUMIFS($B$2:$B$@,$A$2:$A$@,I$2)+SUMIFS($C$2:$C$@,$A$2:$A$@,I$2)", "@", UBound(a))
    [I4].Resize(, .Count) = Replace("=SUMIFS($D$2:$D$@,$A$2:$A$@,I$2)+SUMIFS($E$2:$E$@,$A$2:$A$@,I$2)", "@", UBound(a))
    [I5].Resize(, .Count) = Replace("=SUMIFS($F$2:$F$@,$A$2:$A$@,I$2)", "@", UBound(a))
    [I3].Resize(3, .Count) = [I3].Resize(3, .Count).Value '<--- Comment this line if you wish to retain your formulas
End With

End Sub