Trying to sort by custom order - excel

Question

I am trying to sort a list order to the order of BMC-, CSR-, MC- and CSR-. This list exist on column B and has data on column C.
Sub telecomsorter()
Dim vCustom_Sort As Variant, rr As Long
vCustom_Sort = Array("BMC-", "CSR-", "MC-", "LC-", Chr(42))
Application.AddCustomList ListArray:=vCustom_Sort
With Worksheets("TELECOM")
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row 'Find the last row for the given table
Range("B13:C" & LastRow).Select
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Add2 Key:=Range("B13:B47"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("TELECOM").Sort
.SetRange Range("B13:C" & LastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
I want the list to be in the order of:
BMC-
CSR-
MC-
LC-
If there are multiple strings that are the same, then I want to sort according to the order of column C.

Answer 1

Give it a try to this... I removed the array and add the sorting values directly to the Sort properties.
CustomOrder:="BMC-,CSR-,MC-,LC-," & Chr(42) & ""
Option Explicit
Sub telecomsorter()
Dim LastRow As Long
With Worksheets("TELECOM")
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range("B13:C" & LastRow).Select
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Add2 Key:=Range( _
"B14:B" & LastRow & ""), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"BMC-,CSR-,MC-,LC-," & Chr(42) & "", DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Add2 Key:=Range( _
"C14:C" & LastRow & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("TELECOM").Sort
.SetRange Range("B13:C" & LastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
EDIT: I couldn't figure it out why the LC- always comes before the MC-, so I made a small function to do the workaround... it may not be the ideal solution but it works.
Option Explicit
Sub telecomsorter()
Dim LastRow As Long
Dim First As Long
Dim Last As Long
With Worksheets("TELECOM")
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range("B13:C" & LastRow).Select
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TELECOM").Sort.SortFields.Add Key:=Range( _
"B14:B" & LastRow & ""), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"BMC-*,CSR-*,MC-*,LC-*," & Chr(42) & "", DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("B14:C" & LastRow)
.Header = xlNo
.Orientation = xlTopToBottom
.Apply
End With
Call SortSpecial("LC-*", xlDescending)
Call SortSpecial("MC-*", xlAscending)
Call SortSpecial("LC-*", xlAscending)
End With
End Sub
Public Function SortSpecial(ByVal StrVal As String, ByVal SortOrder As XlSortOrder)
Dim First As Long
Dim Last As Long
First = Columns("B").Find(StrVal, , xlValues, , xlRows, xlNext, , , False).Row
Last = Columns("B").Find(StrVal, , xlValues, , xlRows, xlPrevious, , , False).Row
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("B" & First & ":B" & Last), SortOn:=xlSortOnValues, Order:=SortOrder, DataOption:=xlSortNormal
With ActiveSheet.Sort
If SortOrder = xlAscending Then
.SetRange Range("B" & First & ":C" & Last)
Else
Last = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
.SetRange Range("B" & First & ":C" & Last)
End If
.Header = xlNo
.Orientation = xlTopToBottom
.Apply
End With
End Function