Vba to filter table and add total row when cell value changes in column

[KGEORGE13]

HELLO,

I HAVE A WORKSHEET THAT LOOKS SOMETHING LIKE THIS...

QUANTITY	PART #
4	A
2	C
1	B
3	A
1	A
2	B
5	C

<tbody>
</tbody>

I AM LOOKING FOR A VBA TO SORT AND FILTER THE TABLE TO LOOK LIKE ...

QUANTITY	PART #
4	A
3	A
1	A
8	TOTAL
1	B
2	B
3	TOTAL
2	C
5	C
7	TOTAL

<tbody>
</tbody>

THIS WILL BE A CONTINUOUSLY RUNNING TEMPLATE TO COPY ORDER FORMS IN, SO IT NEEDS TO BE ABLE TO HANDLE THAT.


THANK YOU!

 

[MickG]

Maybe this to overwrite columns "A & B".

[COLOR="Navy"]Sub[/COLOR] MG04Sep44
[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] K [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nSum [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR] .Add Dn.Value, New Collection
        .Item(CStr(Dn.Value)).Add CStr(Dn.Offset(, -1).Value)
    [COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To 2, 1 To 1)
c = 1
Ray(1, 1) = "QUANTITY": Ray(2, 1) = "PART#"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
     [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] .Item(K)
          c = c + 1
          ReDim Preserve Ray(1 To 2, 1 To c)
          Ray(1, c) = P
          Ray(2, c) = K
          nSum = nSum + P
     [COLOR="Navy"]Next[/COLOR] P
        c = c + 1
        ReDim Preserve Ray(1 To 2, 1 To c)
        Ray(1, c) = nSum
        Ray(2, c) = "TOTAL"
        nSum = 0
 [COLOR="Navy"]Next[/COLOR] K
Range("a1").Resize(c, 2) = Application.Transpose(Ray)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick