Sorting Data from Multiple Pages by Date Based on Description

Mlwhiteman

New Member
Joined
Nov 26, 2017
Messages
12
Hello,

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)
MonthDayVendorAmountCategorySubcategoryNotes
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

<tbody>
</tbody>


BEFORE (Month 2 Summary)
MonthDayVendorAmountCategorySubcategoryNotes
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

<tbody>
</tbody>


AFTER (Category Summary)
DateNotesAmount
CVS
1/1Tem1$5.00
1/3Tem4$30.00
2/1Tem6$30.00
2/3Tem9$45.00
etc.



<tbody>
</tbody>

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!

Code:
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)
             Else
                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)
    .Parent.Range("A:D").ClearContents
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
End With    
End Sub
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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.
Code:
[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
               [COLOR="Navy"]Else[/COLOR]
                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")
    .Columns.AutoFit
    .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

Threads
1,148,176
Messages
5,745,191
Members
423,931
Latest member
thangvan114

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 MrExcel.com.
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 "mrexcel.com".
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
Top