Попытка сортировки по индивидуальному заказу

Question

Я пытаюсь отсортировать список по порядку BMC-, CSR-, MC- и CSR-.Этот список существует в столбце B и содержит данные в столбце 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

Я хочу, чтобы список был в следующем порядке:

• BMC-
• CSR-
• MC-
• LC-

Если есть несколько одинаковых строк, то я хочусортировать по порядку столбца С.

Answer 1

Попробуйте это ... Я удалил массив и добавил значения сортировки непосредственно в свойствах сортировки.

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

РЕДАКТИРОВАТЬ: Я не мог 'Я не могу понять, почему LC- всегда предшествует MC-, поэтому я сделал небольшую функцию для обхода проблемы ... это может быть не идеальное решение, но оно работает.

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