Solved

Group Data Based on Week

Posted on 2012-03-15
4
186 Views
Last Modified: 2012-03-25
I need Experts help create a macro which is able to group rows at Data sheet from Monday to Sunday based on date at column A. Hope this is possible. I manually group the data at data sheet for Experts to get a better view.
SortData-2.xls
0
Comment
Question by:Billa7
  • 3
4 Comments
 
LVL 41

Expert Comment

by:dlmille
ID: 37727828
Please see attached which ungroups, sorts the data, then groups data based on week.


Sub SortingAtoR()
Dim lastRow As Long
Dim r As Range
Dim rDelete As Range

    On Error Resume Next
    Rows.RemoveSubtotal
    Rows.Ungroup
    On Error GoTo 0
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Intersect(Range("A1").CurrentRegion, Range("A:R")).Sort _
        Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
        
    Range("S1").Value = "WeekNum"
    Range("S2:S" & lastRow).Formula = "=WEEKNUM($A2)"
    
    Range("A1:S" & lastRow).Subtotal GroupBy:=19, Function:=xlSum, TotalList:=Array(19), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    'remove subTotals
    For Each r In Range("A:A").SpecialCells(xlCellTypeBlanks)
        If rDelete Is Nothing Then
            Set rDelete = r.Resize(, Range("S1").Column)
        Else
            Set rDelete = Union(r.Resize(, Range("S1").Column), rDelete)
        End If
    Next r
    
    rDelete.Delete shift:=xlUp
    Range("S:S").ClearContents
End Sub

Open in new window


See attached.

Dave
SortData-r1.xls
0
 
LVL 41

Accepted Solution

by:
dlmille earned 500 total points
ID: 37727862
I see you want to group on Weeks from Monday to Tuesday.  That just requires a change of the formula on line 17 to:

=weeknum($A2,2) 'the second parameter if omitted or 1 starts on Sunday, 2 starts on Mondays


Sub SortingAtoR()
Dim lastRow As Long
Dim r As Range
Dim rDelete As Range

    On Error Resume Next
    Rows.RemoveSubtotal
    Rows.Ungroup
    On Error GoTo 0
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Intersect(Range("A1").CurrentRegion, Range("A:R")).Sort _
        Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
        
    Range("S1").Value = 1
    Range("S2:S" & lastRow).Formula = "=weeknum($A2,2)" 'week numbering starting on monday
    
    Range("A1:S" & lastRow).Subtotal GroupBy:=19, Function:=xlSum, TotalList:=Array(19), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    'remove subTotals
    For Each r In Range("A:A").SpecialCells(xlCellTypeBlanks)
        If rDelete Is Nothing Then
            Set rDelete = r.Resize(, Range("S1").Column)
        Else
            Set rDelete = Union(r.Resize(, Range("S1").Column), rDelete)
        End If
    Next r
    
    rDelete.Delete shift:=xlUp
    Range("S:S").ClearContents
End Sub

Open in new window


See attached.

Dave
SortData-2-r2.xls
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37759469
Billa - are we done with this, ready for close out?

Dave
0
 

Author Closing Comment

by:Billa7
ID: 37762525
Thanks a lot Dave.

Sorry for the late respond.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager is not included in Office 2013. This comes as a shock to users upgrading from earlier versions of Office, such as 2007 and 2010, where Picture Manager was included as a standard application. This article explains how…
My experience with Windows 10 over a one year period and suggestions for smooth operation
This video walks the viewer through the process of creating envelopes and labels, with multiple names and addresses. Navigate to the “Start Mail Merge” button in the Mailings tab: Follow the step-by-step process until asked to find the address doc…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…

867 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

25 Experts available now in Live!

Get 1:1 Help Now