VBA, Sum part of substring

[Snackan1986]

Hi,

Setup:
I have data in colum "B:D". In column "B" there is an item number, in column "C" there is a category of the item (always 2 digits long) and in colum "D" I have an amount for each category. Note that all values in column "C" and column "D" is in the same cell (ctrl+alt+enter). Note that the category in column "C" always is on the same line as the amount in column "D")

Problem:
I need to summarise this in another table(or pivot table) as the screen shot below in column "G:J". If possible I want it solved through VBA so that I won´t need a lot of helper columns to solve it.

	B	C	D	E	F	G	H	I	J
Detailed	Summary
Item	Short	Amount	Item	AA	BB	CC
Item1	AA AA AA BB CC	Item1
Item2	AA BB BB BB CC	Item2
Item3	etcetera	etcetera	Item3
Item4	etcetera	etcetera	Item4

<tbody>
[TD="align: center"]2[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]1000
-400
1000
-2000
-5000[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]1600[/TD]
[TD="align: right"]-2000[/TD]
[TD="align: right"]-5000[/TD]

[TD="align: center"]5[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]6[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]7[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]8[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

</tbody>

​

Thanks
[TABLE="width: 85%"]
<tbody>[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

Try this for Results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG01Sep18
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp1 [COLOR="Navy"]As[/COLOR] Variant, k [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("C4", Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
ReDim ray(1 To Rng.Count, 1 To 1)
ray(1, 1) = "Item"
ac = 1
[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]
        Sp = Split(Dn.Value, vbLf)
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
           [COLOR="Navy"]If[/COLOR] Not .exists(Sp(n)) [COLOR="Navy"]Then[/COLOR]
               .Add (Sp(n)), ac
                ac = ac + 1
                ReDim Preserve ray(1 To Rng.Count, 1 To ac)
                ray(1, ac) = Sp(n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
 
  [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.Offset(, -1)
      [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]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
            Sp = Split(Dn.Offset(, 1).Value, vbLf)
            Sp1 = Split(Dn.Offset(, 2).Value, vbLf)
                [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                    [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Sp(n)) [COLOR="Navy"]Then[/COLOR]
                        Dic(Dn.Value).Add (Sp(n)), Sp1(n)
                    [COLOR="Navy"]Else[/COLOR]
                        Dic(Dn.Value).Item(Sp(n)) = Val(Dic(Dn.Value).Item(Sp(n))) + Val(Sp1(n))
                    [COLOR="Navy"]End[/COLOR] If
               [COLOR="Navy"]Next[/COLOR] n
      [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]Next[/COLOR] Dn
   
   
    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)
              ray(c, .Item(p) + 1) = Dic(k).Item(p)
            [COLOR="Navy"]Next[/COLOR] p
   
    [COLOR="Navy"]Next[/COLOR] k

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("a1").Resize(c, UBound(ray, 2))
    .Value = ray
    .Borders.Weight = 2
   .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Snackan1986]

There seems two be two faults. It says subscript out of range on the "Dic(Dn.Value).Add (Sp), Sp1" as per below and if on this "ray(c, 1) = k" . Do you know what it could be?

For n = 0 To UBound(Sp)
                    If Not Dic(Dn.Value).exists(Sp(n)) Then
                        Dic(Dn.Value).Add (Sp(n)), Sp1(n)
                    Else
                        Dic(Dn.Value).Item(Sp(n)) = Val(Dic(Dn.Value).Item(Sp(n))) + Val(Sp1(n))
                    End If
               Next n

For Each k In Dic.Keys
        c = c + 1
        ray(c, 1) = k
            For Each p In Dic(k)
              ray(c, .Item(p) + 1) = Dic(k).Item(p)
            Next p

 

[Snackan1986]

Sorry, the first part don´t show any faults anymore (it was because the data was incorrect). but the second part is still not working. Really appreciate the help and if you could solve also this little fault.

 

[MickG]

I think its about how the data in columns "C & D" is entered and how the code reads them.
Ctrl+Alt+Enter Does not appear to create a new line in a particular cell, but "Alt+Enter" does, and is what I used to create a copy of your sheet.
Please see the example file below, and let me know any difference in how your data is entered:-
https://app.box.com/s/72ecs2krv5a43tmtropyb0wsqlosxoe6

 

[Snackan1986]

The problem is because row five does not have any data in your file I noticed (and mine do, except in the example I used in my post above where I had missed that data. If you copy the data from row 4 to row 5 the macro is not working. But if row 5 is empty it´s working. But it works perfect besides from that.

I think its about how the data in columns "C & D" is entered and how the code reads them.
Ctrl+Alt+Enter Does not appear to create a new line in a particular cell, but "Alt+Enter" does, and is what I used to create a copy of your sheet.
Please see the example file below, and let me know any difference in how your data is entered:-
https://app.box.com/s/72ecs2krv5a43tmtropyb0wsqlosxoe6

 

[MickG]

I think the problem is that the array "Ray" was not large enough, .i.e. it does not cater for the header row
Alter the two lines below to add a "1", as shown.

ReDim Ray(1 To Rng.Count + 1, 1 To 1)
'and 
 ReDim Preserve Ray(1 To Rng.Count + 1, 1 To Ac)

 

[Snackan1986]

I think I found a solution to the problem. If I add +1 to the counter it works perfect as per below. Thanks a lot for your help. This will save a lot of time for me in the future.

ReDim Ray(1 To Rng.Count + 1, 1 To 1)

ReDim Preserve Ray(1 To Rng.Count + 1, 1 To Ac)

 

[MickG]

You're welcome