Расширенная сортировка в Excel

Question

У меня есть данные в excel в формате:

Description      Name            Percent
Always             A               52
Sometimes          A               23
Usually            A               25      
Always             B               60
Sometimes          B               30
Usually            B               15 
Always             C               75
Sometimes          C               11
Usually            C               14

Я хочу отсортировать эти данные:

Для каждого имени последовательность описания должна быть одинаковой (например: всегда сопровождаемая иногда сопровождаемая обычно), но для трех имен A, B и C я хочу отсортировать всегда процент от наименьшего к наибольшему. Например: я хочу, чтобы приведенный выше пример выглядел так после сортировки:

Description      Name            Percent
Always             C               75
Sometimes          C               11
Usually            C               14      
Always             B               60
Sometimes          B               30
Usually            B               15 
Always             A               52
Sometimes          A               23
Usually            A               25

Всегда процент имени C был самым высоким, а всегда процент имени A был самым низким. Я надеюсь, что смог объяснить это. Буду очень признателен за вашу помощь относительно того же.

Answer 1

Вот процедура vba для выполнения такой сортировки:

Выберите данные на листе и запустите SortList

Важно: в этом коде предполагается, что данные Always, Sometimes, Usually сгруппированы по Name (как в данных примера)

Метод:

Sub SortList()
    Dim dat As Variant
    Dim rng As Range
    Dim newDat() As Variant
    Dim always() As Long
    Dim i As Long

    Set rng = Selection

    If rng.Columns.Count <> 3 Then
        MsgBox "Select a range with 3 columns", vbCritical + vbOKOnly
        Exit Sub
    End If

    If StrComp(rng.Cells(1, 1), "Description", vbTextCompare) = 0 Then
        Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, 3)
    End If

    dat = rng
    ReDim always(1 To UBound(dat, 1) / 3)

    For i = 1 To UBound(dat)
        If StrComp(dat(i, 1), "Always", vbTextCompare) = 0 Then
            always(i \ 3 + 1) = i
        End If
    Next

    QuickSort dat, always, LBound(always, 1), UBound(always, 1)


    ReDim newDat(1 To UBound(dat, 1), 1 To 3)
    For i = 1 To UBound(always)
        newDat((i - 1) * 3 + 1, 1) = dat(always(i), 1)
        newDat((i - 1) * 3 + 1, 2) = dat(always(i), 2)
        newDat((i - 1) * 3 + 1, 3) = dat(always(i), 3)

        ' Assumes original data is sorted in name order
        newDat((i - 1) * 3 + 2, 1) = dat(always(i) + 1, 1)
        newDat((i - 1) * 3 + 2, 2) = dat(always(i) + 1, 2)
        newDat((i - 1) * 3 + 2, 3) = dat(always(i) + 1, 3)
        newDat((i - 1) * 3 + 3, 1) = dat(always(i) + 2, 1)
        newDat((i - 1) * 3 + 3, 2) = dat(always(i) + 2, 2)
        newDat((i - 1) * 3 + 3, 3) = dat(always(i) + 2, 3)

    Next

    rng = newDat

End Sub


Private Sub QuickSort(ByRef dat As Variant, ByRef Field() As Long, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As Variant, TEMP As Long

    P1 = LB
    P2 = UB
    Ref = dat(Field((P1 + P2) / 2), 3)

    Do
        Do While dat(Field(P1), 3) > Ref
            P1 = P1 + 1
        Loop

        Do While dat(Field(P2), 3) < Ref
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(dat, Field, LB, P2)
    If P1 < UB Then Call QuickSort(dat, Field, P1, UB)
End Sub

Quicksort адаптирован из этот ответ Конрад Рудольф

Answer 2

Это может быть проще с ADO:

Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer

strFile = "C:\Docs\Book2.xlsm"

''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''Comment out the connection string, as appropriate.
''This is the Jet 4 connection string, for < 2007:

strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''ACE, for 2007 -
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''Late binding, so no reference is needed

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")


cn.Open strCon

strSQL = "SELECT s1.[Description], s1.[Name], s1.[Percent] " _
       & "FROM [Sheet3$] s1 " _
       & "INNER JOIN (SELECT s.Name, s.Percent " _
       & "FROM [Sheet3$] s " _
       & "WHERE s.Description='Always') As s2 " _
       & "ON s1.Name = s2.Name " _
       & "ORDER BY s2.Percent DESC, s1.Description"

rs.Open strSQL, cn, 3, 3


''Pick a suitable empty worksheet or location for the results
With Worksheets("Sheet4")
    For i = 1 To rs.Fields.Count
        .Cells(1, i) = rs.Fields(i - 1).Name
    Next

    .Cells(2, 1).CopyFromRecordset rs
End With

''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

Answer 3

Сортировка по описанию. Добавьте эту формулу в столбец D = RANK (VLOOKUP (INDIRECT ("B" & ROW ()), B: C, 2, FALSE), C: C) и сортируйте столбец D с наименьшего до наибольшего.