Sleeper: Trying to Sort "Multiple Rows" together

[charles80]

Hi, I have been a long time reader, first time poster.
I have a problem that I can not seem to figure out.

Typically, when you sort, excel sorts row by row depending upon setting.

I have created "multiple rows" or blocks of information made up of 4 rows.
I want to keep these "blocked" together during my sorting.

I have attached the sample excel of what I am trying to do. In the real document, I have over 800,000 "test cases" to try to sort.

I am wanting to sort "Value 2" / Column B by largest to smallest, but I am wanting the "Case"/Column D to all stay together.

Any pointers or help will be greatly appreciated!

[Paul_Hossler]

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

[p45cal]

Check carefully if this gives the results you want:
Sub blah()
Sheets("Combined").Copy After:=Sheets(Sheets.Count) 'remove this line to act on the active sheet.
With ActiveSheet.Range("D1").CurrentRegion.EntireRow.Resize(, 9)
Application.DisplayAlerts = False
.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(2), Replace:=True, PageBreaks:=False, SummaryBelowData:=False
Application.DisplayAlerts = True
.Parent.Outline.ShowLevels RowLevels:=2
.Sort key1:=.Columns(2), order1:=xlDescending, Header:=xlYes, SortMethod:=xlPinYin
.EntireColumn.RemoveSubtotal
End With
End SubThe first line makes a copy of the Combined sheet so as not to disturb that sheet for comparison purposes; remove it to work on the active sheet.

There's a button on that sheet which runs the above code.



You can do this manually by selecting the table, including the headers, doing a subtotal via the Subtotal button in the Outline section of the Data tab of the ribbon, click OK on the warning about using the top row as column labels, and make the following choices:
26028

Click on the little box with 2 in it:
26029

Your data should still be selected but if it's not select it again and sort it on Value 2, Largest to Smallest, Data has headers:
26030

Select the whole table again, go into the Subtotals dialogue again and click the Remove All button in the bottom left corner.
That's it.