Sorting sections within large table

[Javid]

Hi dear Lucas
I'll be appreciate if you help me too with my problem almost the same.
I have a large table with more than 5000 rows with more than 700 section, each section have their own data in about 7 to 11 rows and what i need is to have a code to sort each section with my selection rows and sorting them by column Q. this column is permanently fixed for my sorting.
i mean there is no need to ask user which column i need to sort by.
i will be thankful if you would help me for my challenge.
here is a part of my table:
partial_table1.jpg
For example i want to select rows in each part of my table hat has No.1 of 2 or... in column A but from G column to Ah and then sort them based on column Q with minimum number on top.

[SamT]

WOW! Lookee all those Merged Cells; and Images, Hidden Columns, Colored Rows, Highlighted Cells, Borders and Conditional Formats.

I pass. Good luck.

The only Formatting there should be is: The Entire Header Row Height Resized, Bold, Font Size +1, Wrap Text, and Bottom Border. Maybe a Border above each section. A Header that covers many Columns (V:W; Y:Z) can be Formatted "Center Across Selection". Vertical Center is OK (A,B,C; V:W)

What you have is a single Database Table with 700 Sections, each of which must be found and programmatically described. Very complex operation with Merged Cells. Looks something like

 
Set FirstCell = TitleCell.MergesArea.Cells(1)
LastRow = TitleCell.MergedArea.Cells(TitleCell.MergedArea.Cells.Count).Row
LastColumn = Cells(Columns.Count, "A").End(xlToRight).Column
Set LastCell = Range(LastRow, LastColumn)
Set Section = Range(FirstCell, LastCell)

If you follow my Formatting guidelines above, AND Insert an Empty Row above each Section's Top Border, AND add a vertical Border on the Right that covers only that Table's Rows, you will have 700 DB Tables, any one of which can be described by

Table = TitleCell.CurrentRegion

[Javid]

Hi dear SamT,
I appreciate of your attention and response.
And also many thanks for your helpful tips, I'll try to edit and change my table and then will test your code on it.
Hope it solves my problem.
Let me say I learned great lessons from your tips.
Thanks again and Good luck

[p45cal]

try running this which acts on the active sheet:

Sub blah()
Set mydict = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
For Each cll In Range("B12:B" & lr).Cells
  If Not mydict.exists(cll.MergeArea.Address) Then mydict.Add cll.MergeArea.Address, cll.MergeArea
Next cll
For Each itm In mydict.items
  itm.EntireRow.Columns("G:AH").Sort key1:=Range("Q1"), order1:=1
Next itm
End Sub

[Javid]

Hi dear friend,
So many thanks for your answer and code.
I tried to test it but it gives me no act on my data file
Thanks again and good luck.

[p45cal]

Hi dear friend,
So many thanks for your answer and code.
I tried to test it but it gives me no act on my data file
Thanks again and good luck.

That's why pictures are useless; column B looks like merged cells in the picture, but they're not.
Column A does have merged cells so changing my offering to look at that instead of column B gives:

Sub blah()
Set mydict = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
For Each cll In Range("A12:A" & lr).Cells
  If Not mydict.exists(cll.MergeArea.Address) Then mydict.Add cll.MergeArea.Address, cll.MergeArea
Next cll
For Each itm In mydict.items
  itm.EntireRow.Columns("G:AH").Sort key1:=Range("Q1"), order1:=1
Next itm
End Sub

and works over here.

[Javid]

Oh Dear my friend it's working very nice
Thank you so much for your help

[Javid]

Now i need another help:
How may i change the background of two cells "I" and "Q" in each row with conditional format based on cell "Q" just where cell Q containing the minimum price, in whole data sheet?
These two cells is important because of the minimum price in cell Q and the vendor's name.
In fact I need yellow background for both of these cells, even if we don't sort each or some sections yet, but just where lower price and it's vendor name are both in the same row.
And It's clear that whenever sorting is done, the yellow background will shift with the sorting.

[Aussiebear]

Javid, are you able to upload a sample file so we can test our suggestions?

[Javid]

Dear Aussiebear I did upload an image sample on my request, do you mean a sample of excel file you need?
Otherwise Would you please tell me how can i upload my Excel sample file?
I can't see any tools in toolbar for attaching excel file!
Sample File.xlsx
Hope i did it right

[Aussiebear]

"Images", are for polar bears in space suits. Just a dummy file with some sample data (must be similar) will be fine.

[Javid]

Thanks and let me know that can you see my attachment now?

[Aussiebear]

First issue I can see is apart from the merged cells is that if we use "Column Q to sort Minimum to Maximum" there are blank cells. What happens to that data?

[Javid]

First issue I can see is apart from the merged cells is that if we use "Column Q to sort Minimum to Maximum" there are blank cells. What happens to that data?

The section with no entry will change with it's own data soon, so we don't need to change or move them in data sheet

[Aussiebear]

Yes I can. Just for future reference you can attach files by clicking on Go Advanced/ Manage Attachments/ Choose File/ Upload

[Javid]

Thanks my friend

[Paul_Hossler]

1. How do you want Col Q sorted?

For example, section 1 has 1 entry filled outy of 7 rows, and section 2 has 2 cells filled in out of 7 rows


2. Sort each section keeping the rows together? Which entry do I sort by (e.g. section 2 has 2)?

3. Delete rows with no entry in column Q, or just sort them to the bottom?

Capture.JPG

[georgiboy]

If you amend your formula in column Q From:

=IF(OR(P12=0,M12=0),"",P12/M12)

To:

=IF(OR(P12=0,M12=0),0,P12/M12)

And are hell bent on keeping the merged cells then:

Sub test()    
    Dim wsCP As Worksheet, rng As Range, rCell As Range, tmpRng As Range
    
    Set wsCP = Sheets("Comparateur prix")
    Set rng = wsCP.Range("A12:A" & wsCP.Range("A" & Rows.Count).End(xlUp).Row)


    Set tmpRng = rng(1, 1)
    For Each rCell In rng.Cells
        With rCell
            If .MergeCells Then
                If Intersect(rCell, tmpRng) Is Nothing Then
                    .MergeArea.Offset(, 6).Resize(.MergeArea.Rows.Count, 27).Sort wsCP.Range("Q9"), xlDescending
                    Set tmpRng = .MergeArea
                End If
            End If
        End With
    Next
End Sub

Hope this helps

[Javid]

So many thanks dear Georgiboy,
Let me test your code and will notify the result.

[p45cal]

try:

Sub blah()
Set mydict = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
For Each cll In Range("A12:A" & lr).Cells
  If Not mydict.exists(cll.MergeArea.Address) Then mydict.Add cll.MergeArea.Address, cll.MergeArea
Next cll
Range("Q:Q,I:I").FormatConditions.Delete
For Each itm In mydict.items
  itm.EntireRow.Columns("G:AH").Sort key1:=Range("Q1"), order1:=1
  Set rngCF = Intersect(itm.EntireRow, Range("I:I,Q:Q"))
  With rngCF.FormatConditions.Add(Type:=xlExpression, Formula1:="=" & rngCF.Areas(2).Cells(1).Address(0, 1) & "=MIN(" & rngCF.Areas(2).Address & ")")
    .StopIfTrue = False
    With .Interior
      .PatternColorIndex = xlAutomatic
      .Color = 65535
      .TintAndShade = 0
    End With
  End With
Next itm
End Sub

Don't forget to remove any manual colours you've put in.