Сортировка VBA - развернуть код на 6 столбцов

Question

Мне было интересно, может ли кто-нибудь помочь мне расширить следующий код для работы с 6 столбцами. Это уже работает довольно хорошо для любого количества строк. Как добавить ту же конструкцию для столбцов? Имя пользователя: assylias создал этот код, и я пытаюсь адаптировать его для своих потребностей сортировки.

Проблема: Мне нужно отсортировать что-то вроде этого

X A 3
X B 7
X C 2
X D 4
Y E 8
Y A 9
Y B 11
Y F 2

Его нужно отсортировать следующим образом: Столбец, где X и Y представляют группы. Буквы: A, B, C, D, E, F обозначают членов группы. Числа - это некоторая метрика, по которой мы сравниваем их. Наибольшее число и связанный с ним участник, который получил это число, является «лидером» этой группы, и я хочу отсортировать данные таким образом, чтобы каждый руководитель каждой группы сравнивался с каждым членом этой группы следующим образом:

X  B A 3
X  B C 2
X  B D 4
Y  B E 8
Y  B A 9
Y  B F 2

Объяснение: Б оказывается лидером обеих групп. Мне нужно сравнить его со всеми другими членами и справа от их ячейки, иметь столбец, показывающий число, которое они заработали.

Проблема: в коде Ассилии я сейчас пытаюсь расширить его до своего набора данных. В моем наборе данных есть 6 столбцов, поэтому есть множество качественных столбцов для описания каждого члена (например, State, ID # и т. Д.), И мне нужна помощь в расширении кода, чтобы охватить это. Также, если это возможно, объяснения некоторых шагов (возможно, в форме комментариев) позволили бы мне лучше соединить точки лучше. (В основном, я не понимаю, что такое dict1 / dict2 и что именно они делают ... (например, dict1.exists (data (i, 1))) для меня неочевидно.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
doIt
End Sub
Public Sub doIt()

Dim data As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim dict1 As Variant
Dim dict2 As Variant

Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
data = Sheets("Sheet1").UsedRange

For i = LBound(data, 1) To UBound(data, 1)
    If dict1.exists(data(i, 1)) Then
        If dict2(data(i, 1)) < data(i, 3) Then
            dict1(data(i, 1)) = data(i, 2)
            dict2(data(i, 1)) = data(i, 3)
        End If
    Else
        dict1(data(i, 1)) = data(i, 2)
        dict2(data(i, 1)) = data(i, 3)
    End If
Next i

ReDim result(LBound(data, 1) To UBound(data, 1) - dict1.Count, 1 To 4) As Variant

j = 1
For i = LBound(data, 1) To UBound(data, 1)
    If data(i, 2) <> dict1(data(i, 1)) Then
        result(j, 1) = data(i, 1)
        result(j, 2) = dict1(data(i, 1))
        result(j, 3) = data(i, 2)
        result(j, 4) = data(i, 3)
        j = j + 1
    End If
Next i

With Sheets("Sheet2")
    .Cells(1, 5).Resize(UBound(result, 1), UBound(result, 2)) = result
End With

End Sub

Answer 1

Я прокомментировал код и исправил его, чтобы получить 6 столбцов.Теперь это быстрый выстрел, поэтому его можно улучшить, оптимизировать и т. Д.

Public Sub doIt()

    Dim inputData As Variant
    Dim result As Variant
    Dim thisGroup As String
    Dim thisMember As String
    Dim thisScore As String
    Dim i As Long
    Dim j As Long
    Dim membersWithHighestScore As Variant 'Will store the member with highest score for each group
    Dim highestScore As Variant 'Will store the highest score for each group

    Set membersWithHighestScore = CreateObject("Scripting.Dictionary")
    Set highestScore = CreateObject("Scripting.Dictionary")
    inputData = Sheets("Sheet1").UsedRange

    'First step: populate the dictionaries
    'At the end of the loop:
    '   - membersWithHigestScore will contain the member with the highest score for each group, for example: X=B, Y=B, ...
    '   - highestScore will contain for example: X=7, Y=11, ...
    For i = LBound(inputData, 1) To UBound(inputData, 1)
        thisGroup = inputData(i, 1) 'The group for that line (X, Y...)
        thisMember = inputData(i, 2) 'The member for that line (A, B...)
        thisScore = inputData(i, 3) 'The score for that line
        If membersWithHighestScore.exists(thisGroup) Then 'If there already is a member with a high score in that group
            If highestScore(thisGroup) < thisScore Then 'if this new line has a higher score
                membersWithHighestScore(thisGroup) = thisMember 'Replace the member with highest score for that group with the current line
                highestScore(thisGroup) = thisScore 'This is the new highest score for that group
            End If 'If the line is not a new high score, skip it
        Else 'First time we find a member of that group, it is by definition the highest score so far
            membersWithHighestScore(thisGroup) = thisMember
            highestScore(thisGroup) = thisScore
        End If
    Next i

    ReDim result(LBound(inputData, 1) To UBound(inputData, 1) - membersWithHighestScore.Count, 1 To 7) As Variant

    j = 1
    For i = LBound(inputData, 1) To UBound(inputData, 1)
        thisGroup = inputData(i, 1) 'The group for that line (X, Y...)
        thisMember = inputData(i, 2) 'The member for that line (A, B...)
        If thisMember <> membersWithHighestScore(thisGroup) Then 'If this is a line containing the highest score for that group, skip it
            result(j, 1) = thisGroup
            result(j, 2) = membersWithHighestScore(thisGroup)
            'Copy the rest of the data as is
            result(j, 3) = inputData(i, 2)
            result(j, 4) = inputData(i, 3)
            result(j, 5) = inputData(i, 4)
            result(j, 6) = inputData(i, 5)
            result(j, 7) = inputData(i, 6)
            j = j + 1
        End If
    Next i

    With Sheets("Sheet2")
        .Cells(1, 5).Resize(UBound(result, 1), UBound(result, 2)) = result
    End With

End Sub