Sorting Data from Multiple Pages by Date Based on Description


New Member
Nov 26, 2017

I am attempting to generate an organized list of all entries from multiple sheets which have a date, vendor, cost, category, subcategory, and notes. I am looking to have them sorted by date based upon their vendor, and to display the original date, notes, and cost of the data which belongs to the particular vendor. 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 A1. Any help would be appreciated. Thanks!

BEFORE (Month 1 Summary)
11CVS$5.00Cat 1Subcat 1Tem1
11Home Depot$10.00Cat 1Subcat 2Tem2
12McDonald's$15.00Cat 1Subcat 3Tem3
13CVS$20.00Cat 2Subcat 1Tem4
14Home Depot$25.00Cat 2Subcat 2Tem5


BEFORE (Month 2 Summary)
21CVS$30.00Cat 1Subcat 1Tem6
21Home Depot$35.00Cat 1Subcat 2Tem7
22McDonald's$40.00Cat 1Subcat 3Tem8
23CVS$45.00Cat 2Subcat 1Tem9
24Home Depot$50.00Cat 2Subcat 2Tem10


AFTER (Category Summary)


Below is code which is similar, but organized the data by category and subcategory rather than vendor. I believe that all that has to be done is reallocate the fields within the dictionary but I'm unsure how to do that exactly. Any help would be appreciated! Thanks!

Option Explicit

Private Sub CommandButton1_Click()
Dim Dic         As Object
Dim Rng1        As Range, Rng2 As Range
Dim Rng         As Range, Dn As Range
Dim k           As Variant
Dim p           As Variant
Dim G           As Variant
Dim c           As Long
Dim Q           As Variant
Dim R           As Long
Dim Ac          As Integer
Dim n           As Long
Dim Dt          As Date
Dim Ray         As Variant
With Sheets("Month 1 Summary")
    Set Rng1 = .Range("F6", .Range("F" & Rows.Count).End(xlUp))
End With
With Sheets("Month 2 Summary")
    Set Rng2 = .Range("F6", .Range("F" & Rows.Count).End(xlUp))
End With
Ray = Array(Rng1, Rng2)

Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   For Ac = 0 To 1
    For Each Dn In Ray(Ac)
    If Not Dic.exists(Dn.Value) Then
            Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
        End If
            If Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) Then
                Set Dic(Dn.Value)(Dn.Offset(, 1).Value) = CreateObject("Scripting.Dictionary")
                    Dic(Dn.Value)(Dn.Offset(, 1).Value).CompareMode = 1
            End If
              If Not Dic(Dn.Value)(Dn.Offset(, 1).Value).exists(Dn.Offset(, -2).Value) Then
                    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)
                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
            End If
    Next Dn
 Next Ac
c = 1
ReDim Ray(1 To (Rng1.Count + Rng2.Count) * 3, 1 To 4)
Ray(1, 2) = "Date": Ray(1, 3) = "Description": Ray(1, 4) = "Amount"
For Each k In Dic.Keys
           c = c + 1
           Ray(c, 1) = k
        For Each p In Dic(k).Keys
                c = c + 1
                Ray(c, 2) = p
            For Each G In Dic(k)(p).Keys
                For 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, "MMM/dd/yyyy")
                    Ray(c, 3) = G
                    Ray(c, 4) = Dic(k)(p).Item(G)(0)(R, 3)
                Next R
            Next G
            c = c + 1
        Next p
Next k

With Sheets("Category Summary").Range("B1:D1")
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
End With

With Sheets("Category Summary").Range("A1").Resize(c, 4)
    .Value = Ray
    .Borders.Weight = 2
End With    
End Sub

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.


MrExcel MVP
Jan 9, 2008
Try this for Results on Sheet "Category Summary"
NB:- Any sheet with the first word in the sheet name being "Month" will be taken into account for the Results.
[COLOR="Navy"]Sub[/COLOR] MG12Jan14
[COLOR="Navy"]Dim[/COLOR] Ws [COLOR="Navy"]As[/COLOR] Worksheet, R [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[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] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
            Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] Worksheets
    R = Ws.Cells(1).CurrentRegion.Resize(, 7)
    [COLOR="Navy"]If[/COLOR] Left(Ws.Name, 5) = "Month" [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] n = 2 To UBound(R, 1)
                [COLOR="Navy"]If[/COLOR] Not Dic.Exists(R(n, 3)) [COLOR="Navy"]Then[/COLOR]
                    ReDim Ray(1 To 3, 1 To 1)
                        Ray(1, 1) = Format(DateSerial(Year(Now), R(n, 1), R(n, 2)), "dd-mmm")
                        Ray(2, 1) = R(n, 7)
                        Ray(3, 1) = R(n, 4)
                    Dic.Add R(n, 3), Ray
                Q = Dic(R(n, 3))
                    ReDim Preserve Q(1 To 3, 1 To UBound(Q, 2) + 1)
                        Q(1, UBound(Q, 2)) = Format(DateSerial(Year(Now), R(n, 1), R(n, 2)), "dd-mmm")
                        Q(2, UBound(Q, 2)) = R(n, 7)
                        Q(3, UBound(Q, 2)) = R(n, 4)
                Dic(R(n, 3)) = Q
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Ws
[COLOR="Navy"]Dim[/COLOR] c       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k       [COLOR="Navy"]As[/COLOR] Variant
c = 2

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
  [COLOR="Navy"]With[/COLOR] Sheets("Category Summary")
    .Range("A1").Resize(, 4).Value = Array("Vendor", "Date", "Notes", "Amount")
    .Cells(c, "A") = k
    c = c + 1
    .Cells(c, "B").Resize(UBound(Dic(k), 2), 3) = Application.Transpose(Dic(k))
    c = c + UBound(Dic(k), 2) + 1
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick

Forum statistics

Latest member

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
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 "".
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