Group Data Based on Week

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
Billa7Asked:
Who is Participating?
 
dlmilleCommented:
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
 
dlmilleCommented:
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
 
dlmilleCommented:
Billa - are we done with this, ready for close out?

Dave
0
 
Billa7Author Commented:
Thanks a lot Dave.

Sorry for the late respond.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.