Sort employees names in the same order in data

[YasserKhalil]

Hello everyone
I have a table of employees' data and the names in the second column. What I would like to do is to aggregate and sort the names but in the same order in the main database. The data is in the range A1 to C16 and the expected output in F1 to H16
To make the question clearer I have copied the names in column K and removed the duplicates to clarify the issue well. The names should be the same order as in column K (column K is just for clarification)

[YasserKhalil]

I could find an old thread that helped me in solving the issue

Code: Select all

Sub Test()
    Dim a, x, ws As Worksheet, dic As Object, i As Long, n As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    a = ws.Range("A1").CurrentRegion.Columns(2).Value
    For i = LBound(a) + 1 To UBound(a)
        If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
    x = dic.Keys
    Application.AddCustomList x
    n = Application.CustomListCount
    With ws
        .Range("A1").CurrentRegion.Sort Key1:=.Range("B1"), Header:=xlYes, OrderCustom:=n + 1
        .Sort.SortFields.Clear
    End With
    Application.DeleteCustomList n
End Sub

[SpeakEasy]

Or, perhaps more succinctly:

Code: Select all

    Dim myField As SortField

    With ActiveWorkbook.Worksheets("Sheet1").Sort
        Set myField = .SortFields.Add(Key:=Range("B2:B16"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Nader,Hany,Ahmed,Reda,Salah,Kamal", DataOption:=xlSortNormal)
        .SetRange Range("A1:C16")
        .Header = xlYes
        .Apply
    End With
    myField.Delete

[YasserKhalil]

Thanks a lot but you hard-coded the names and I have large list of names
Best Regards

[YasserKhalil]

How to modify the code so as to keep the names sorted as it is (this point is solved) and within each name (each same group) to sort the data by column E then by column F from oldest date to recent data.
so the order of custom sort (names) followed by column E and finally by column F (the dates)

[YasserKhalil]

This is my try till now but the names not sorted as expected

Code: Select all

Sub Test()
    Dim a, x, ws As Worksheet, dic As Object, i As Long, n As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    Dim c As Range
    For Each c In ws.UsedRange.Columns("F").Cells
        If c.Row > 1 Then c.Value = CDate(c.Value)
    Next c
    a = ws.Range("A1").CurrentRegion.Columns(2).Value
    For i = LBound(a) + 1 To UBound(a)
        If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
    x = dic.Keys
    Application.AddCustomList x
    n = Application.CustomListCount
        With ws
        .Range("A1").CurrentRegion.Sort Key1:=.Range("E1"), Order1:=xlAscending, Key2:=.Range("F1"), Order2:=xlDescending, Header:=xlYes, OrderCustom:=n + 1
        .Sort.SortFields.Clear
    End With
    Application.DeleteCustomList n
End Sub

[YasserKhalil]

I think this solved the problem. But I have a problem at this line

Code: Select all

.SortFields.Add Key:=Range("B1"), CustomOrder:="ow, bv, xz"

I tried to replace "ow, bv, xz" with x variable but doesn't work and throws an error

Code: Select all

Sub Test()
    Dim a, x, ws As Worksheet, dic As Object, i As Long, n As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    Dim c As Range
    For Each c In ws.UsedRange.Columns("F").Cells
        If c.Row > 1 Then c.Value = CDate(c.Value)
    Next c
    a = ws.Range("A1").CurrentRegion.Columns(2).Value
    For i = LBound(a) + 1 To UBound(a)
        If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
    x = dic.Keys
    x = Join(x, ", ")
    Application.AddCustomList x
    n = Application.CustomListCount
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B1"), CustomOrder:="ow, bv, xz"
        .SortFields.Add Key:=Range("E1"), Order:=xlAscending
        .SortFields.Add Key:=Range("F1"), Order:=xlAscending
        .SetRange Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    Application.DeleteCustomList n
End Sub

[SpeakEasy]

Ok - so it was unclear to me from your first post how you were defining the sort order (I assumed from the list you provided) - but it now seems as if what you are doing is sorting by the order in which the names first appear in the list. If that is the case, then the following would resolve your original post (if I have misunderstood then the custom sort order won't be built correctly), but with the Age column standing in for your later date column to show how you might do subsorting

Code: Select all

Sub Example()
    Dim myField As SortField
    Dim myField2 As SortField
    Range("A1:C16").Copy
    Range("f1").Select
    ActiveSheet.Paste
    

    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear

    With ActiveWorkbook.Worksheets("Sheet1").Sort
        Set myField = .SortFields.Add(Key:=Range("G2:G16"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=vbTextJoin(Range("B2:B16"), ","), DataOption:=xlSortNormal)
        Set myField2 = ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Key:=Range("h2:h16"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal)
        .SetRange Range("f1:h16")
        .Header = xlYes
        .Apply
    End With
    
    myField2.Delete
    myField.Delete
End Sub

' Simplistic, limited vba version of Excel365s TEXTJOIN function
Public Function vbTextJoin(myRange As Range, Optional Seperator As String = "") As String
    Dim myitem
    For Each myitem In myRange
        vbTextJoin = vbTextJoin & Seperator & myitem.Value
    Next
End Function

[YasserKhalil]

Solved by modifying this part `CustomOrder:=Join(x, ",") & vbNullString`.
Thanks a lot Mr. SpeakEasy for sharing the problem.

[YasserKhalil]

This is the final working code for the last attachment

Code: Select all

Sub Test()
    Dim a, x, ws As Worksheet, c As Range, dic As Object, i As Long, n As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    For Each c In ws.UsedRange.Columns("F").Cells
        If c.Row > 1 Then c.Value = CDate(c.Value)
    Next c
    a = ws.Range("A1").CurrentRegion.Columns(2).Value
    For i = LBound(a) + 1 To UBound(a)
        If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
    x = dic.Keys
    Application.AddCustomList x
    n = Application.CustomListCount
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B1"), CustomOrder:=Join(x, ",") & vbNullString
        .SortFields.Add Key:=Range("E1"), Order:=xlAscending
        .SortFields.Add Key:=Range("F1"), Order:=xlAscending
        .SetRange Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    Application.DeleteCustomList n
End Sub