Consulting

Results 1 to 3 of 3

Thread: Sleeper: Trying to Sort "Multiple Rows" together

  1. #1

    Sleeper: Trying to Sort "Multiple Rows" together

    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!
    Attached Files Attached Files

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    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 Sub
    The 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:
    2020-02-19_143648.jpg

    Click on the little box with 2 in it:
    2020-02-19_144037.jpg

    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:
    2020-02-19_144255.jpg

    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.
    Attached Files Attached Files
    Last edited by p45cal; 02-19-2020 at 07:48 AM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •