Excel VBA排序-展开6列代码

我想知道是否有人可以帮助我扩展以下代码，使其在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

说明：B恰好是两个小组的组长。我需要将他与所有其他成员进行比较，在他们牢房的右边有一列，显示他们的收入

问题：配备了Assylias的代码，我现在正试图将其扩展到我的数据集。我的数据集有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

Private子工作表\u selection更改（ByVal目标作为范围）
多伊特
端接头
公共子doIt（）
作为变量的Dim数据
作为变量的模糊结果
我想我会坚持多久
Dim j尽可能长
Dim dict1作为变体
Dim dict2作为变体
Set dict1=CreateObject（“Scripting.Dictionary”）
Set dict2=CreateObject（“Scripting.Dictionary”）
数据=表（“表1”）。使用表格
对于i=LBound（数据，1）到UBound（数据，1）
如果dict1.存在（数据（i，1）），则
如果dict2（数据（i，1））小于数据（i，3），那么
dict1（数据（i，1））=数据（i，2）
dict2（数据（i，1））=数据（i，3）
如果结束
其他的
dict1（数据（i，1））=数据（i，2）
dict2（数据（i，1））=数据（i，3）
如果结束
接下来我
ReDim结果（LBound（数据，1）到UBound（数据，1）-dict1.Count，1到4）作为变量
j=1
对于i=LBound（数据，1）到UBound（数据，1）
如果数据（i，2）是1（数据（i，1）），那么
结果（j，1）=数据（i，1）
结果（j，2）=dict1（数据（i，1））
结果（j，3）=数据（i，2）
结果（j，4）=数据（i，3）
j=j+1
如果结束
接下来我
附页（“第2页”）
.单元格（1，5）.调整大小（UBound（结果，1），UBound（结果，2））=结果
以

---

End Sub

我已经对代码进行了注释并对其进行了修改，以获得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

Public Sub doIt（）
作为变量的Dim输入数据
作为变量的模糊结果
将此组设置为字符串
将此成员设置为字符串
将该乐谱变暗为字符串
我想我会坚持多久
Dim j尽可能长
Dim Members WithHighestScore As Variant'将存储每组得分最高的成员
Dim highestScore As Variant'将存储每组的最高分数
Set membersWithHighestScore=CreateObject（“Scripting.Dictionary”）
设置highestScore=CreateObject（“Scripting.Dictionary”）
输入数据=工作表（“表1”）。使用表格
'第一步：填充字典
'在循环结束时：
'-memberswithhighestscore将包含每组得分最高的成员，例如：X=B，Y=B。。。
“-最高分将包含例如：X=7，Y=11。。。
对于i=LBound（inputData，1）到UBound（inputData，1）
thisGroup=inputData（i，1）'该行的组（X，Y…）
thisMember=inputData（i，2）'该行的成员（A，B…）
thisScore=输入数据（i，3）'该行的分数
如果存在得分最高的成员（此组），则“如果该组中已有得分较高的成员”
如果最高分（本组）

我做了一些研究，发现代码中使用的“dictionary”对象不支持多维性。那么我们是否应该将其作为数组进行重新处理？这可能是一个解决方案。您可以从这些线程中找到一些灵感：这是一个非常清晰、非常有用的代码。这完全回答了我的问题，并为我提供了一个解决方案