Function ActivateReportWorksheet()
Set ReportSH = ThisWorkbook.Sheets("Report")
ReportSH.Activate
End Function

Sub SortMultipleColumns()
'www.Tricks12345.com
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Report").Delete
Dim InputSH As Worksheet
Set InputSH = ThisWorkbook.Sheets("Input")
ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Report"
ActivateReportWorksheet
'Key denotes about first sort field
InputSH.Range("A1").CurrentRegion.Copy ReportSH.Range("A1")
ReportSH.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
'ReportSH.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
' Custom Sort
ReportSH.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, _
CustomOrder:="Apple, Orange, Grapes, Banana, Pineapple", DataOption:=xlSortNormal
Lastrow = ReportSH.Range("A" & Rows.Count).End(xlUp).Row
With ReportSH.Sort
.SetRange Range("A1:C" & Lastrow)
.Header = xlYes 'Data consists of Header or not
.MatchCase = False ' True for case sensitive, false for noncase sensitive
.Orientation = xlTopToBottom ' Denotes where sort is in ascending or descending
.SortMethod = xlPinYin ' Excel supports chinese language also
.Apply
End With
ReportSH.UsedRange.Columns.AutoFit
Call GroupTheRows
End Sub

Sub GroupTheRows()
'ActivateReportWorksheet
r = 2
StartingRow = 2
Do Until ReportSH.Range("A" & r).Value = ""
ReportSH.Range("A" & r).Activate
If ReportSH.Range("A" & r + 1) = "" Then
ReportSH.Range(Cells(StartingRow, 1), Cells(r, 1)).Rows.Group
Exit Do
End If
If ReportSH.Range("A" & r).Value <> ReportSH.Range("A" & r + 1).Value Then
ReportSH.Range("A" & r + 1).EntireRow.Insert
ReportSH.Range(Cells(StartingRow, 1), Cells(r, 1)).Rows.Group
StartingRow = r + 2
r = r + 1
End If
r = r + 1
Loop
End Sub

Sub Ungroup_the_rows()
ActivateReportWorksheet
Lastrow = ReportSH.Range("A" & Rows.Count).End(xlUp).Row
ReportSH.Range("A2:A" & Lastrow).Rows.Ungroup
For r = Lastrow To 2 Step -1
Cells(r, 1).Activate
If Cells(r, 1).Value = "" Then
Cells(r, 1).EntireRow.Delete
End If
Next
End Sub