Consolidate Data

Cartillo
Cartillo used Ask the Experts™
on
Hi Experts,

I would like to request Experts help create a code to consolidate data at "Date Query" sheet based on data set at "Order" sheet. The search date queries are entered at cell C3 and C5 (Date Query) sheet. All titles which were booked under the selected date (Start/End Date) from Order sheet need to be displayed.

I have manually created a sample data at "Date Query" sheet for Experts to get a better view. Hope Experts will help me create this feature.

OrderList-V2.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Most Valuable Expert 2012
Top Expert 2012
Commented:
Cartillo,

This was a bit of a fun project, as I chose to build on my learnings wrt matthewspatrick's ParentClass Builder Article and Add-In tool http:/A_3802.html.  As a result, once I had the data structure created, it was fairly easy to read in the data, then spit it back out in the format desired.  One interesting thing about your input data is that the same activity may have more than one occurrance on a given date/time slot.  As a result, I had to track the number of timestamps for each Activity/Date/Time slot.

I had wanted to use dictionary objects, however, collections gave me the flexibility (coupled with the ParentClass Builder) so I added a couple new functions to ensure only unique values were added to my collections, etc., and thus the essence of the dictionary theme is built into this design.

The app processes all rows of data, but selecting left and right column based on the date parameters set on the output sheet.  I created a simple dynamic named range to feed that dropdown list, setting DateList  =Order!$B$2:INDEX(Order!$2:$2,MATCH(99^99,Order!$2:$2))

As the app processes each "slot" (date/time intersection), it parses out "Activities" (e.g., "TitleF", etc.) that may exist in each cell, using the SPLIT command and vbCr.  It "cleans" the activity name as there appear to be some special, nonprintable characters in the cells, so that ensures we have a clean Activity name from which to process.

For each activity in a given cell, aDate and aTime variables are set based on the date/time intersections in the table.

The activity is added to the Activities collection, then the date is added to the Act_Dates child collection underneath Activities, and finally, the time is added to the Times collection underneat Act_Dates.  If the activity exists more than once in a date/time slot, then the Act_Time_Count property of the Time class is incremented by one.

On the output side, its pretty straight forward - iterate through activities, then dates, then times (if more than one), building an output string for the Date(Time list) output you requested.  A total of # timestamps is reported to the right, and a subTotal for the entire activity is reported at the bottom, as your output example demonstrated.

Here's the primary code (without posting the class definitions):
 
Sub gatherData()
Dim myCell As Range, fRange As Range
Dim lastRow As Long, firstCol As Long, lastCol As Long, i As Long
Dim startDate As Date, endDate As Date
Dim inSheet As Worksheet
Dim outSheet As Worksheet
Dim Activities As clsActivities, myActivity As clsActivity
Dim myDate As clsDate, myTime As clsTime
Dim aDate As String, aTime As String
Dim outCursor As Range, outLine As Range, tmpStr As String
Dim actValues As Variant, actItem As Variant, chkStr As String
Dim subTot As Long
    
    Set Activities = New clsActivities
    
    Set inSheet = ThisWorkbook.Sheets("Order")
    Set outSheet = ThisWorkbook.Sheets("Date Query")
    
    outSheet.Range("D10:F" & Rows.Count).Clear
    outSheet.Range("F:F").HorizontalAlignment = xlCenter
    
    Set outCursor = outSheet.Range("D10")
    
    lastRow = inSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    startDate = Format(outSheet.Range("C3").Value, "D-MMM")
    endDate = Format(outSheet.Range("C5").Value, "D-MMM")
    
    If IsEmpty(startDate) Then
        firstCol = 2
    Else
        Set fRange = inSheet.Range("2:2").Find(what:=startDate, LookIn:=xlFormulas, lookat:=xlWhole)
        If Not fRange Is Nothing Then
            firstCol = fRange.Column
        Else
            MsgBox "Invalid Start Date Entry - try again", vbCritical, "Aborting"
            Exit Sub
        End If
    End If
    
    If IsEmpty(endDate) Then
        lastCol = inSheet.Cells(2, Columns.Count).End(xlToLeft).Column
    Else
        Set fRange = inSheet.Range("2:2").Find(what:=endDate, LookIn:=xlFormulas, lookat:=xlWhole)
        If Not fRange Is Nothing Then
            lastCol = fRange.Column
        Else
            MsgBox "Invalid End Date Entry - try again", vbCritical, "Aborting"
            Exit Sub
        End If
    End If
    
    'Step1:  Gather the slots - Activity name stored in dictionary, Date/Time parameters stored in array of index in dictionary
    For Each myCell In inSheet.Range("B3", inSheet.Cells(lastRow, lastCol))

        actValues = Split(myCell.Value, vbCr) ' split out by carriage returns
        
        For Each actItem In actValues
            chkStr = Application.WorksheetFunction.Clean(actItem)

            If chkStr <> "" Then
            
                aDate = Format(inSheet.Cells(2, myCell.Column).Value, "D-MMM")
                aTime = Format(inSheet.Cells(myCell.Row, 1).Value, "HH:MM")
                
                If Not Activities.Exists(chkStr) Then
                    Set myActivity = Activities.Add(chkStr)
                Else
                    Set myActivity = Activities.Key(chkStr)
                End If
            
                If Not myActivity.Act_Dates.Exists(aDate) Then
                    Set myDate = myActivity.Act_Dates.Add(aDate)
                Else
                    Set myDate = myActivity.Act_Dates.Key(aDate)
                End If
                
                If Not myDate.Times.Exists(aTime) Then
                    Set myTime = myDate.Times.Add(aTime)
                Else
                    Set myTime = myDate.Times.Key(aTime)
                    myTime.Act_Time_Count = myTime.Act_Time_Count + 1 'keep track of duplicate time stamps for same activity, same day, same time
                End If
                
            End If
        Next actItem
    Next myCell
    
    'Step2:  Generate output, by Activity, then Date/Time combinations
    For Each myActivity In Activities
        outCursor.Value = myActivity.Act_Name
        subTot = 0
        
        For Each myDate In myActivity.Act_Dates
            tmpStr = myDate.Act_Date & " ("
            
            For Each myTime In myDate.Times
                For i = 0 To myTime.Act_Time_Count
                    tmpStr = tmpStr & myTime.Act_Time & " ; "
                Next i
            Next myTime
            
            tmpStr = Left(tmpStr, Len(tmpStr) - 3) & ")"
            outCursor.Offset(0, 1).Value = tmpStr
            outCursor.Offset(0, 2).Value = myDate.Times.Count
            
            subTot = subTot + myDate.Times.Count
            
            Set outCursor = outCursor.Offset(1, 0)
        Next myDate
        outCursor.Offset(0, 2).Value = "[" & subTot & "]"
        outCursor.Offset(0, 2).Font.Color = 255
        Set outCursor = outCursor.Offset(1, 0)

        outCursor.Resize(1, 3).Borders(xlEdgeTop).LineStyle = xlContinuous

    Next myActivity
End Sub

Open in new window


See attached example spreadsheet.  I hooked the button you had to the macro provided in the gatherDataModule module.

Cheers,

Dave
OrderList-V2-r4.xlsm

Author

Commented:
Hi dlmille,

Thanks a lot of detailing each process, it’s very clear for me to understand how the whole script works to generate each line.
After testing few data I noticed the query not return if the query is crossed from current year to next year. E.g.

Start Date: 21-Nov
End Date: 31-Jan (2012)

Is that any possibility to make this query feasible.
Kevin CrossChief Technology Officer
Most Valuable Expert 2011

Commented:
dlmille,

Could it be the date format? I will leave you to help Cartillo, but was just passing by and saw the issue. I would try it with date format: YYYY-MM-DD or 2011-11-21. That way the start and end date comparisons behave more appropriately respect to chronology versus potentially doing an alphanumeric sort.

Kevin
Expert Spotlight: Joe Anderson (DatabaseMX)

We’ve posted a new Expert Spotlight!  Joe Anderson (DatabaseMX) has been on Experts Exchange since 2006. Learn more about this database architect, guitar aficionado, and Microsoft MVP.

Most Valuable Expert 2012
Top Expert 2012

Commented:
Sure - it all has to do with the formatting of the dates.  I had to add YY to the date designation in the sheet for the dropdown and in the code to discriminate between years and it now works with multiple years.

Be sure to credit my original post as well, so matthewspatrick's article http:/A_3802.html gets credit.

See attached,

Cheers,

Dave
OrderList-V2-r5.xlsm

Author

Commented:
Hi Dave,

Thanks for the revised code. When I search data for 1-Aug 2011 to 31-Aug 2011, data for 1-Jan 2011 to 20-Feb 2011 also appeared. How to make only query result being displayed.
Most Valuable Expert 2012
Top Expert 2012
Commented:
Apologies - I had done the "work" to determine the first column (firstCol) to process, but didn't put it in my loop.  The line should read:

    For Each myCell In inSheet.Range(inSheet.Cells(3, firstCol), inSheet.Cells(lastRow, lastCol))


See attached.

Dave
OrderList-V2-r6.xlsm

Author

Commented:
Hi Dave,

Thanks a  lot for helping me create this booking tools.

Hi mwvisa1,

Thanks for the comment.
Most Valuable Expert 2012
Top Expert 2012

Commented:
Cartillo - any need to sort the output - e.g., by Activity?  Let me know, as I could write a quick sort function in the class (hadn't done that as yet, so was wondering if this was the opportunity).

Dave

Author

Commented:
Hi Dave,

First of all, thanks for your willingness. Actually, I have another issue with this workbook, which is deleting unwanted data based on Date/Time. The macro able to delete a specific data based on the Date filter but not with a specific time and frequency. Hope you could help me to enhance this feature. I'll ask a new question for this. Please consider.

Author

Commented:
Hi Dave,

Hope you will consider this Q:(pertaining with the same workbook)

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27246880.html

Most Valuable Expert 2012
Top Expert 2012

Commented:
For the record, I created a Sort function to sort the Activities class collection.  

You can do:

Activities.Sort to sort ascending, Activities.Sort(False) to sort descending.

This was my first attempt at doing some of this, but looks like good results.  Happy to have any E-E experts comment.

The code in question, under the clasee clsActivities is as follows (just for expert comment), in particular the functions: ItemSorted, Exists, Key, and Sort.

Exists - to mimic the Dictionary.Exists function
Key - to mimic the Dictionary.Key function
Sort - to sort the Activities Class collection (it doesn't change the collection, but updates the Act_Rank property so that one can loop through in Ranked fashion)
ItemSorted - to return the Activity based on an Index, looking at the Act_Rank property

' dmbw, CVX April, 2011
' Created 2011-08-08

' Parent collection class of clsActivity

'Option Explicit
Option Compare Text

' Container for all clsActivity objects in the parent collection class
Private coll As Collection

Private Sub Class_Initialize()
    
    Set coll = New Collection
    
End Sub

Private Sub Class_Terminate()
    
    Set coll = Nothing
    
End Sub

Public Function Add(Act_Name As String) As clsActivity
    
    ' Adds a new item to the collection.  Causes an error if an item with the same key already exists
    ' or if you pass a zero length string for the Act_Name argument
    
    If Act_Name = "" Then
        Err.Raise vbObjectError + 1002, , "Act_Name property of clsActivity object cannot be zero length string"
    End If
    
    Set Add = New clsActivity
    Add.Act_Name = Act_Name
    coll.Add Add, Act_Name
    
End Function

Public Sub Clear()
    
    ' Recreates (and thus clears) collection
    
    Set coll = New Collection
    
End Sub

Property Get Count() As Long
    
    ' Returns number of items in the collection
    
    ' Read-only
    
    Count = coll.Count
    
End Property

Property Get Item(Index As Variant) As clsActivity
    
    ' Default property.  Returns an item from the collection.  Index may be either ordinal position (Long) or Act_Name (String)
    
    ' Read-only
    
    On Error Resume Next
    Set Item = coll(Index)
    On Error GoTo 0
    
End Property

Property Get ItemSorted(Index As Variant) As clsActivity
Dim myItem As Object

    If Not coll Is Nothing Then
        
        On Error Resume Next
        For Each myItem In coll
            If myItem.Act_Rank = Index Then
                Set ItemSorted = myItem
                Exit Function
            End If
        Next myItem
        On Error GoTo 0
    End If
    
End Property
Public Sub Remove(Index As Variant)
    
    ' Removes an item from the collection.  Index may be either ordinal position (Long) or Act_Name (String)
    
    coll.Remove Index
    
End Sub

Function NewEnum() As IUnknown

    ' Enables enumeration of the clsActivities parent collection, i.e.:
    '
    ' For Each Child In Parent...Next
    
    Set NewEnum = coll.[_NewEnum]
End Function

Function Exists(Act_Name As String) As Boolean
Dim myItem As Object

    If Not coll Is Nothing Then
        For Each myItem In coll
            If myItem.Act_Name = Act_Name Then
                Exists = True
                Exit Function
            End If
        Next myItem
    End If
    
    Exists = False
End Function

Function Key(Act_Name As String) As clsActivity
Dim myItem As Object

    If Not coll Is Nothing Then
        For Each myItem In coll
            If myItem.Act_Name = Act_Name Then
                Set Key = myItem
                Exit Function
            End If
        Next myItem
    End If
    
    Key = Null
End Function

Function Sort(Optional sortAscending As Boolean = True)
Dim tmp As Variant, myAct As Object
Dim i As Long
Dim changed As Boolean
Dim tmpColl As New Collection

'Simple bubble sort approach...

'create a temporary collection for sorting
    For Each myAct In coll
        tmpColl.Add myAct.Act_Name
    Next myAct
    
'now sort that collection
    Do
        changed = False
        For i = 1 To tmpColl.Count - 1
            If sortAscending Then
                If tmpColl(i) > tmpColl(i + 1) Then
                    tmp = tmpColl(i + 1)
                    tmpColl.Remove i + 1
                    tmpColl.Add tmp, tmp, i
                    changed = True
                End If
            Else
                If tmpColl(i) < tmpColl(i + 1) Then
                    tmp = tmpColl(i + 1)
                    tmpColl.Remove i + 1
                    tmpColl.Add tmp, tmp, i
                    changed = True
                End If
            End If
        Next i
    Loop Until Not changed

'now update the Act_Rank property of the Activities class collection

    For i = 1 To tmpColl.Count
        For Each myAct In coll
            If myAct.Act_Name = tmpColl(i) Then
                myAct.Act_Rank = i
                Exit For
            End If
        Next myAct
    Next i
    
    Set tmpColl = Nothing
End Function

Open in new window


See attached "final" submital for the knowledgebase.

I'll take a look at your outstanding question, to see if I can help.

See attached.

Cheers,

Dave
OrderList-V2-r7.xlsm
Kevin CrossChief Technology Officer
Most Valuable Expert 2011

Commented:
Very nicely done, Dave!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial