Consulting

Results 1 to 3 of 3

Thread: Trying to Sort "Multiple Rows" together

  1. #1

    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 Wizard
    Joined
    Apr 2007
    Posts
    7,134
    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

    ------------------------------------------------------------------------------------------------------------------------
    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)
    (multiple files can be selected while holding Ctrl key) / 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 Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,952
    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 - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    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
  •