Try this
Takes each block of 4 lines and stings them out onto one line on a temp sheet
Sorts that sheet
Puts back onto original as 4 lines
Option Explicit
Sub SortMacro()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim colA As Range, rowA As Range
Dim rowOut As Long, rowOut2 As Long
Dim rSort As Range, rSort1 As Range
Application.ScreenUpdating = False
Set ws1 = Worksheets("Combined")
'create new temp WS. deleting old
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add.Name = "temp"
Set ws2 = Worksheets("temp")
'get cells with data in col A
Set colA = ws1.Columns(1).SpecialCells(xlCellTypeConstants)
rowOut = 1
'put side by side on tem WS
For Each rowA In colA.Rows
If rowA.Row = 1 Then
ws1.Cells(1, 1).Resize(1, 9).Copy ws2.Cells(rowOut, 1)
Else
ws1.Cells(rowA.Row, 1).Resize(1, 9).Copy ws2.Cells(rowOut, 1)
ws1.Cells(rowA.Row + 1, 4).Resize(1, 6).Copy ws2.Cells(rowOut, 10)
ws1.Cells(rowA.Row + 2, 4).Resize(1, 6).Copy ws2.Cells(rowOut, 16)
ws1.Cells(rowA.Row + 3, 4).Resize(1, 6).Copy ws2.Cells(rowOut, 22)
End If
rowOut = rowOut + 1
Next
'sort temp WS
Set rSort = ws2.Cells(1, 1).CurrentRegion.Resize(, 27)
Set rSort1 = rSort.Cells(2, 2).Resize(rSort.Rows.Count - 1, 1)
With ws2.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort1, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange rSort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'put back on Combined
rowOut2 = 2
For rowOut = 2 To ws2.Cells(1, 1).CurrentRegion.Rows.Count
ws2.Cells(rowOut, 1).Resize(1, 9).Copy ws1.Cells(rowOut2, 1)
ws2.Cells(rowOut, 10).Resize(1, 6).Copy ws1.Cells(rowOut2 + 1, 4)
ws2.Cells(rowOut, 16).Resize(1, 6).Copy ws1.Cells(rowOut2 + 2, 4)
ws2.Cells(rowOut, 22).Resize(1, 6).Copy ws1.Cells(rowOut2 + 3, 4)
rowOut2 = rowOut2 + 4
Next
'create temp WS
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "done"
End Sub