VBA

[Javid_P]

Hi all
I'll be appreciate if you help me with my problem.
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 anyone would help me for my challenge.

here is a part of my table:

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.

 

[Anthony47]

Try the following macro, to be tested on a copy of your workbook:

Sub BlockSort()
Dim SortAdr As String, SortCol As String
Dim SortBlk As Range, KeyBlk As Range, sCnt As Long
'
SortCol = "C:U"                     '<<<< WHICH COLUMNS to sort
Sheets("MySheet").Select            '<<<< The sheet to be sorted
'
For I = 12 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(I, 1) <> "" Then
        SortAdr = Cells(I, 1).MergeArea.Address
        Set SortBlk = Application.Intersect(Range(SortAdr).EntireRow, Range(SortCol))
        If SortBlk.Rows.Count > 3 Then
            Set KeyBlk = Cells(SortBlk.Cells(1, 1).Row, "Q").Resize(SortBlk.Rows.Count, 1)
            Debug.Print SortBlk.Address, KeyBlk.Address
            ActiveSheet.Sort.SortFields.Clear
            ActiveSheet.Sort.SortFields.Add Key:=KeyBlk, SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveSheet.Sort
                .SetRange SortBlk
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            sCnt = sCnt + 1
        End If
    End If
Next I
MsgBox ("Sort completed, " & sCnt & " blocks")
End Sub

Copy it into a standard module of your vba project; the lines marked <<< have to be customized according the comment.
Then run Sub BlockSort

 

[Javid_P]

Try the following macro, to be tested on a copy of your workbook:

Sub BlockSort()
Dim SortAdr As String, SortCol As String
Dim SortBlk As Range, KeyBlk As Range, sCnt As Long
'
SortCol = "C:U"                     '<<<< WHICH COLUMNS to sort
Sheets("MySheet").Select            '<<<< The sheet to be sorted
'
For I = 12 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(I, 1) <> "" Then
        SortAdr = Cells(I, 1).MergeArea.Address
        Set SortBlk = Application.Intersect(Range(SortAdr).EntireRow, Range(SortCol))
        If SortBlk.Rows.Count > 3 Then
            Set KeyBlk = Cells(SortBlk.Cells(1, 1).Row, "Q").Resize(SortBlk.Rows.Count, 1)
            Debug.Print SortBlk.Address, KeyBlk.Address
            ActiveSheet.Sort.SortFields.Clear
            ActiveSheet.Sort.SortFields.Add Key:=KeyBlk, SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveSheet.Sort
                .SetRange SortBlk
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            sCnt = sCnt + 1
        End If
    End If
Next I
MsgBox ("Sort completed, " & sCnt & " blocks")
End Sub

Copy it into a standard module of your vba project; the lines marked <<< have to be customized according the comment.
Then run Sub BlockSort

 

[Javid_P]

Wowwwwww
Dear Anthony,
So many Thanks for your answer to my request as well as the code you took the trouble to write and send me??
It worked easily and quickly and sorted all 712 parts of my data!
I appreciate for your kindness?
Good Luck man.

 

[Javid_P]

Dear Anthony;
Would i have a new request too?
Would you please help me how to highlight background of two cells on top of each sections after sorting, in "I" & "Q" columns too?
I set it for "Q" column with additional format because of each time the value maybe changed and just it must have yellow background if the value is less than others in their Q column, but i need this method for column I too because of this column containing the vendors name.
I Don't know how can i add this in my table.
In fact, the condition for changing the background behind the cell "I" is to establish this condition for cell "Q" first.
I'll appreciate for your helps ?

 

[Anthony47]

Let me understand:
-Q contains a Price and I contains the Vendor; each block is sorted for ascending price, thus the top line should contain the lowest price. So, in which conditions the top Q & I should be set in yellow?

 

[Javid_P]

Let me understand:
-Q contains a Price and I contains the Vendor; each block is sorted for ascending price, thus the top line should contain the lowest price. So, in which conditions the top Q & I should be set in yellow?

Yes you understand right, 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

 

[Anthony47]

Still not clear to me the request...
The following variant for Sub BlockSort will sort by column Q and apply yellow background to Q & I if the price in Q is the lowest (so more than 1 row can be yellow in case of more than 1 vendors offer the best price.

Sub BlockSort()
Dim SortAdr As String, SortCol As String
Dim SortBlk As Range, KeyBlk As Range, sCnt As Long
Dim myC As Range, J As Long
'
SortCol = "C:V"                     '<<<< WHICH COLUMNS to sort
Sheets("MySheet").Select            '<<<< The sheet to be sorted
'
For I = 12 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(I, 1) <> "" Then
        SortAdr = Cells(I, 1).MergeArea.Address
        Set SortBlk = Application.Intersect(Range(SortAdr).EntireRow, Range(SortCol))
        If SortBlk.Rows.Count > 3 Then
            Set KeyBlk = Cells(SortBlk.Cells(1, 1).Row, "Q").Resize(SortBlk.Rows.Count, 1)
            Debug.Print SortBlk.Address, KeyBlk.Address
            ActiveSheet.Sort.SortFields.Clear
            ActiveSheet.Sort.SortFields.Add Key:=KeyBlk, SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveSheet.Sort
                .SetRange SortBlk
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            'Set yellow to lowest:
            KeyBlk.Interior.Color = xlNone
            KeyBlk.Offset(, -8).Interior.Color = xlNone
            For Each myC In KeyBlk
                If Application.WorksheetFunction.Rank(myC.Value, KeyBlk, 1) = 1 Then
                    myC.Interior.Color = RGB(255, 255, 0)
                    myC.Offset(0, -8).Interior.Color = RGB(255, 255, 0)
                Else
                    Exit For
                End If
            Next myC
'
            sCnt = sCnt + 1
        End If
    End If
Next I
MsgBox ("Sort completed, " & sCnt & " blocks")
End Sub

You can see an extra block has been inserted

 

[Javid_P]

Still not clear to me the request...
The following variant for Sub BlockSort will sort by column Q and apply yellow background to Q & I if the price in Q is the lowest (so more than 1 row can be yellow in case of more than 1 vendors offer the best price.

Sub BlockSort()
Dim SortAdr As String, SortCol As String
Dim SortBlk As Range, KeyBlk As Range, sCnt As Long
Dim myC As Range, J As Long
'
SortCol = "C:V"                     '<<<< WHICH COLUMNS to sort
Sheets("MySheet").Select            '<<<< The sheet to be sorted
'
For I = 12 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(I, 1) <> "" Then
        SortAdr = Cells(I, 1).MergeArea.Address
        Set SortBlk = Application.Intersect(Range(SortAdr).EntireRow, Range(SortCol))
        If SortBlk.Rows.Count > 3 Then
            Set KeyBlk = Cells(SortBlk.Cells(1, 1).Row, "Q").Resize(SortBlk.Rows.Count, 1)
            Debug.Print SortBlk.Address, KeyBlk.Address
            ActiveSheet.Sort.SortFields.Clear
            ActiveSheet.Sort.SortFields.Add Key:=KeyBlk, SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveSheet.Sort
                .SetRange SortBlk
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            'Set yellow to lowest:
            KeyBlk.Interior.Color = xlNone
            KeyBlk.Offset(, -8).Interior.Color = xlNone
            For Each myC In KeyBlk
                If Application.WorksheetFunction.Rank(myC.Value, KeyBlk, 1) = 1 Then
                    myC.Interior.Color = RGB(255, 255, 0)
                    myC.Offset(0, -8).Interior.Color = RGB(255, 255, 0)
                Else
                    Exit For
                End If
            Next myC
'
            sCnt = sCnt + 1
        End If
    End If
Next I
MsgBox ("Sort completed, " & sCnt & " blocks")
End Sub

You can see an extra block has been inserted

Hi again Dear Anthony;
Thanks for your kindness and sorry me for trouble.
Unfortunately I gives error while running this code and i don't know if it's my fault or not
Please check out the picture and let me know if i do mistake with your code.

 

[Anthony47]

To refer to column Q you should use SortCol = "Q:Q", not "Q"
BUT the macro will SORT (same as the previous version) the area you specify... Now sorting only column Q would disarray the table, ie the position of data in column Q could change and align the Price of vendor X with Vendor Y, making the table a big mess.
So I guess that it is not the solution for what you asked; but this demonstrated I didn't yet understand your need