tricky sorting using VBA

[luvbite38]

Hi,

Can someone help me fix following pls.

I need to sort out a table using a user defined sequence.

Let me explain more.

In Column 1 of my table I have lets say following

A
A
A
D
D
D
D
E
E
E
A
A

and in another sheet (priority), user can key in the preferred sequence no. against each unique ID from above Table
such as
A 2
D 3
E 1

Now I want macro to read the sequence no. from priority sheets and sort the Table in (Summary Page) for me.

Note: The summary Table is a live Table and values will be keep on adding in it and unique list is currently keeps on updating.

THANKS IN advance.....
Any suggestions pls. . . . .

 

[luvbite38]

Following macro operation Table should looking something like this:
E
E
E
A
A
A
A
A
D
D
D
D

 

[jmthompson]

Could you have a hidden helper column populated with a vlookup formula to return the sort value and then sort based on that column?

 

[luvbite38]

I dunt have any hidden column at the mo, but i think i know where you coming from.

 

[luvbite38]

Ok I have added the seq: nos. from priority sheet in to column U of summary table.

Could you kindly let me know what should I do next?

Thanks for your suggestion earlier.

Kind Regards

 

[Rhino373]

I suggest something like this. This also assumes your data does not exceed 100,000 lines. If it does, you'll need to increase the "FindLastRow" range.

This sorts the first sheet to group all the entries together. It then uses a loop to determine where each letter starts and ends. It uses a cut and paste method in reverse order to sort based on the second sheet.

Function CustomSort()
FindLastRow = Range("A100000").End(xlUp).Row
Sheets(1).Select
Range("A1").Select
Selection.CurrentRegion.Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A" & FindLastRow), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A1:A" & FindLastRow)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Sheets(2).Select
FindLastRowSort = Range("A100000").End(xlUp).Row
Range("A1").Select
Selection.CurrentRegion.Select
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("B1:B" & FindLastRowSort), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
    .SetRange Range("A1:B" & FindLastRowSort)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
For x = FindLastRowSort To 1 Step -1
    SortOrder = Range("A" & x).Value
    Sheets(1).Activate
 
    y = 1
    While Range("A" & y).Value <> SortOrder
        y = y + 1
    Wend
        StartSelection = y
        While Range("A" & y).Value = SortOrder
            y = y + 1
        Wend
        StopSelection = y - 1
    If StartSelection <> 1 Then
        Rows(StartSelection & ":" & StopSelection).Select
        Selection.Cut
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown
    End If
    Sheets(2).Activate
Next
End Function

 

[Rhino373]

This also assumes there are no headers on sheets 1 or 2.

 

[luvbite38]

THANK YOU MILLION TIME

thanks buddy