Выборочная сортировка с использованием разделенной запятыми строки в зависимости от диапазона (ошибка переполнения)

Question

Это расширение моего исходного вопроса, найденного здесь .

Я хочу использовать VBA (2016) для выполнения пользовательской сортировки на основе предварительно определенного диапазона. Я знаю, что CustomOrder: принимает строку, разделенную запятыми, поэтому я пытаюсь передать ей одну из них, основываясь на значениях, найденных в столбце. Я нашел решение для преобразования столбца в строку через запятую , но когда я пытаюсь его реализовать, я получаю ошибку переполнения (6).

Чтобы создать заново, сделайте простая электронная таблица, которая выглядит следующим образом (обратите внимание, что даты уже в порядке возрастания):

Затем используйте приведенный ниже код для выполнения действия. По сути, он сначала копирует и вставляет значения столбца с серийным номером в свой собственный столбец, удаляет эти дубликаты, а затем пытается использовать эти уникальные значения в качестве разделенной запятыми строки для подачи в пользовательскую функцию сортировки для исходного столбца с серийным номером. Затем просто удалите столбец уникальных значений:

Sub Macro7()

' Copy the serial numbers values into their own column
    Columns("A:A").Select
    Selection.Copy
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

' Remove the duplicates from that new column
    ActiveSheet.Range("$D$1:$D$7").RemoveDuplicates Columns:=1, Header:=xlYes
    Columns("A:A").Select

' Create a text string by transposing that column and adding commas to it
    Dim arr As String
    arr = Join(Application.Transpose(Range("D2", Range("D2").End(xlDown)).Value), ",")

' Try to sort the original Serial Number column based on the custom arr string made above
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A2:A8") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        arr, DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:B8")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

' Delete the unique values column
    Columns("D:D").Select
    Selection.ClearContents
End Sub

Я хочу, чтобы конечный результат выглядел следующим образом:

Что я скучаю? Спасибо!

ОБНОВЛЕНИЕ

Наверное, я мог бы добавить, что если вы замените строку:

arr, DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"

... на:

"2222,1111,3333,4444", DataOption:=xlSortNormal 

... код работает. Так что по какой-то причине он не читает переменную arr в виде текстовой строки или по какой-то другой причине? Я не хочу каждый раз вручную определять CustomOrder и хотел бы, чтобы это был шаг в моем VBA, а не выполнялся вручную с помощью пользовательской функции сортировки. Спасибо!

ОБНОВЛЕНИЕ ОТВЕТА

Ответ, показанный ниже, также работает, но я нашел действительно простое решение, изменив строку:

arr, DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"

... to:

CVar(arr), DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"

... я думаю, что именно это преобразует строку в "массив строк". Тогда это работает. Спасибо!

Answer 1

Мне не удалось заставить Worksheet.Sort работать с настраиваемым списком, но я мог использовать Range.Sort

Ключевые элементы:

• Настраиваемый список должен быть массивом Строк
• Добавить список в пользовательские списки, отсортировать, затем удалить его
• Я также убрал зависимость от Select / Active

Sub Demo()
    Dim ws As Worksheet
    Dim SortKeysRange As Range
    Dim SortDataRange As Range
    Dim UniqueKeysRange As Range
    Dim arr() As String, i As Long

    On Error GoTo EH

    Set ws = ActiveSheet ' Update as required
    With ws
        Set SortKeysRange = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
        Set UniqueKeysRange = .Cells(1, 4)

        ' Copy the serial numbers values into their own column
        UniqueKeysRange.Cells(1, 1).Resize(SortKeysRange.Rows.Count, 1) = SortKeysRange.Value

        ' Remove the duplicates from that new column
        Set UniqueKeysRange = .Range(UniqueKeysRange, UniqueKeysRange.End(xlDown))
        UniqueKeysRange.RemoveDuplicates Columns:=1, Header:=xlYes

        Set SortDataRange = SortKeysRange.Resize(, 2)

        ' Create a text string by transposing that column and adding commas to it
        Set UniqueKeysRange = .Range(UniqueKeysRange.Cells(2, 1), UniqueKeysRange.Cells(2, 1).End(xlDown))
        ReDim arr(1 To UniqueKeysRange.Rows.Count)
        For i = 1 To UniqueKeysRange.Rows.Count
            arr(i) = CStr(UniqueKeysRange.Cells(i, 1))
        Next

        'Add custom list
        Application.AddCustomList arr ', True
        i = Application.GetCustomListNum(arr)

        ' Sort
        SortDataRange.Sort _
          Key1:=SortDataRange.Cells(1, 1), _
          Order1:=xlAscending, _
          OrderCustom:=i + 1, _
          Header:=xlYes, _
          MatchCase:=False, _
          Orientation:=xlTopToBottom, _
          SortMethod:=xlPinYin

    End With

EH:

    ' Delete Custom List
    Application.DeleteCustomList i

    ' Delete the unique values column
    UniqueKeysRange.EntireColumn.Clear
End Sub