Sorting Data from Multiple Pages by Date Based on Category and Subcategory

[Mlwhiteman]

Hello,

I am attempting to generate an organized list of all entries from multiple sheets which have a date, description, cost, category, and subcategory. I am looking to have them sorted by date based upon their category and then their subcategory, and to display the original date, description, and cost of the data which belongs to the particular category and subcategory. I have three (3) worksheets for this example: Worksheet #1 : (Month 1 Summary), Worksheet #2 : (Month 2 Summary), and Worksheet #3 (Category Summary). Worksheets #1 and #2 are how the data is currently organized, and Worksheet #3 is the desired result. I am assuming that the header for "Month" begins in cell B3. Any help would be appreciated. Thanks!

BEFORE (Month 1 Summary)
Month	Day	Description	Amount	Category	Subcategory	Notes
1	1	CVS	$5.00	Cat 1	Subcat 1
1	1	Home Depot	$10.00	Cat 1	Subcat 2
1	2	McDonald's	$15.00	Cat 1	Subcat 3
1	3	CVS	$20.00	Cat 2	Subcat 1
1	4	Home Depot	$25.00	Cat 2	Subcat 2

<colgroup><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

BEFORE (Month 2 Summary)
Month	Day	Description	Amount	Category	Subcategory	Notes
2	1	CVS	$30.00	Cat 1	Subcat 1
2	1	Home Depot	$35.00	Cat 1	Subcat 2
2	2	McDonald's	$40.00	Cat 1	Subcat 3
2	3	CVS	$45.00	Cat 2	Subcat 1
2	4	Home Depot	$50.00	Cat 2	Subcat 2

<colgroup><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

AFTER (Category Summary)
	Date	Description	Amount
Cat 1
	Subcat 1
	1/1	CVS	$5.00
	2/1	CVS	$30.00
	Subcat 2
	1/1	Home Depot	$10.00
	2/1	Home Depot	$35.00
	Subcat 3
	1/2	McDonald's	$15.00
	2/2	McDonald's	$40.00
Cat 2
	Subcat 1
	1/3	Shell	$20.00
	2/3	Shell	$45.00
	Subcat 2
	1/4	Michael's	$25.00
	2/4	Michael's	$50.00

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

 

[MickG]

Try this:-
Data on sheets "Month 1 Summary" & "Month 2 Summary"
Results on sheet "Category Summary", all data starting "A1"

[COLOR="Navy"]Sub[/COLOR] MG27Nov30
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Rng1        [COLOR="Navy"]As[/COLOR] Range, Rng2 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] G           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] R           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dt          [COLOR="Navy"]As[/COLOR] Date
[COLOR="Navy"]Dim[/COLOR] Ray         [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] Sheets("Month 1 Summary")
    [COLOR="Navy"]Set[/COLOR] Rng1 = .Range("E2", .Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Month 2 Summary")
    [COLOR="Navy"]Set[/COLOR] Rng2 = .Range("E2", .Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
Ray = Array(Rng1, Rng2)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] Ac = 0 To 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ray(Ac)
    [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
            
            [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(, -2).Value) [COLOR="Navy"]Then[/COLOR]
                   
                    ReDim nRay(1 To Rng1.Count + Rng2.Count, 1 To 3)
                    nRay(1, 1) = Dn.Offset(, -4).Value
                    nRay(1, 2) = Dn.Offset(, -3).Value
                    nRay(1, 3) = Dn.Offset(, -1).Value
                    Dic(Dn.Value)(Dn.Offset(, 1).Value).Add (Dn.Offset(, -2).Value), Array(nRay, 1)
             [COLOR="Navy"]Else[/COLOR]
                Q = Dic(Dn.Value)(Dn.Offset(, 1).Value).Item(Dn.Offset(, -2).Value)
                    Q(1) = Q(1) + 1
                    Q(0)(Q(1), 1) = Dn.Offset(, -4)
                    Q(0)(Q(1), 2) = Dn.Offset(, -3)
                    Q(0)(Q(1), 3) = Dn.Offset(, -1)
                Dic(Dn.Value)(Dn.Offset(, 1).Value).Item(Dn.Offset(, -2).Value) = Q
 
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
 [COLOR="Navy"]Next[/COLOR] Ac
c = 1
ReDim Ray(1 To (Rng1.Count + Rng2.Count) * 2, 1 To 4)
Ray(1, 2) = "Date": Ray(1, 3) = "Description": Ray(1, 4) = "Amount"
[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
                c = c + 1
                Ray(c, 2) = p
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(k)(p).Keys
                [COLOR="Navy"]For[/COLOR] R = 1 To Dic(k)(p).Item(G)(1)
                    c = c + 1
                    Dt = DateSerial("2017", Dic(k)(p).Item(G)(0)(R, 1), Dic(k)(p).Item(G)(0)(R, 2))
                    Ray(c, 2) = Format(Dt, "DD_mmm")
                    Ray(c, 3) = G
                    Ray(c, 4) = Dic(k)(p).Item(G)(0)(R, 3)
                [COLOR="Navy"]Next[/COLOR] R
            [COLOR="Navy"]Next[/COLOR] G
        [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Sheets("Category Summary").Range("A1").Resize(c, 4)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[ArmstrongN]

...or combine the data onto a single sheet and use a pivot table

 

[Mlwhiteman]

Hi Mick,

Thanks for the assistance! When I run the macro I get the message "Type mismatch".

 

[MickG]

Sorry about that,
Try this example file of your posted data, see if you can spot what the problem is.
https://app.box.com/s/pwt7f6kny6lmzuyv36agjlcgpuszkh8r

 

[Mlwhiteman]

Hi Mick,

I noticed where the original problem is. I'm still relatively new to VBA. If I want the original table that you posted on sheets "Month 1 Summary" and "Month 2 Summary" to begin on cell E5, what has to change?

 

[MickG]

Try changing the lines below to reflect a starting point of "E5"

[COLOR=#000080]With[/COLOR] Sheets("Month 1 Summary")
    [COLOR=navy]Set[/COLOR] Rng1 = .Range[B][COLOR=#FF0000]("E5", [/COLOR][/B].Range("E" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Sheets("Month 2 Summary")
    [COLOR=navy]Set[/COLOR] Rng2 = .Range[B][COLOR=#FF0000]("E5", [/COLOR][/B].Range("E" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With