Data Using Double Click on Header but multiple range

[Paul_Hossler]

OK, try this

There's no real error checking to fail softly (like mis-spelling one of the categories), but checks can be added

Option Explicit

Sub SortBlocks()
    Dim rCategory As Range        
    Application.ScreenUpdating = False    
    With ActiveSheet
        Set rCategory = .Columns(2)
        Call SortBlock(rCategory, "Auto Ancillaries")
        Call SortBlock(rCategory, "Auto")
        Call SortBlock(rCategory, "Banks")
    End With
    Application.ScreenUpdating = True
    MsgBox "Sorted"
End Sub

Private Sub SortBlock(r As Range, s As String)
    Dim rLastColumn As Range, rSort As Range, rStart As Range, rEnd As Range    
    With r
        Set rStart = .Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole).Offset(1, 0)
        Set rEnd = rStart.End(xlDown)
        Set rLastColumn = .Parent.Cells(6, .Parent.Columns.Count).End(xlToLeft).EntireColumn
        Set rSort = Range(rStart, Intersect(rEnd.EntireRow, rLastColumn))
    End With
    With r.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rSort.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rSort
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub