Excel VBA中ADO Recordset按自定义顺序排序Groups与Type字段咨询

方案1：调整SQL逻辑（推荐，性能更高无需遍历更新） #

你的排序失效核心原因是：SQL执行时Groups列还是空值，LEFT JOIN得到的排序序号G.ITEM全部为空，后续你在Recordset中更新Groups后，原有排序逻辑已经失效。我们可以把Segment到Groups的映射直接放到SQL关联中，查询时直接得到填充后的Groups值，同时完成自定义排序：
首先确认你的几个映射表结构：

• Segment映射表：shtStudyDetails.B19起两列，列名分别为Segments、Assign Groups（如果你的实际列名不一样修改对应字段名即可）
• Status1排序表：shtStudyDetails.E45:F55，列名Groups、ITEM（ITEM是Groups对应的排序序号，值越小优先级越高）
• Status2排序表：shtStudyDetails.G45:H106，列名Type、ITEM（ITEM是Type对应的排序序号）
  然后调整你的SQL构造部分代码：

' 原来的SELECT字段部分不变，调整FROM后面的关联逻辑
strSQL = strSQL & " FROM ([" & shtPasteData.Name & "$" & xRg.Address(False, False, xlA1) & "] AS A "
' 先关联Segment映射表，直接得到正确的Groups值
strSQL = strSQL & " LEFT JOIN [" & shtStudyDetails.Name & "$B19:C" & xLastRow & "] AS S ON S.[Segments] = A.[segment])"
' 再关联Groups排序表，用映射后的Groups值关联
strSQL = strSQL & " LEFT JOIN [" & shtStudyDetails.Name & "$" & KeyValues1.Address(False, False, xlA1) & "] AS G ON G.[Groups] = S.[Assign Groups]"
' 关联Type排序表逻辑不变
strSQL = strSQL & " LEFT JOIN [" & shtStudyDetails.Name & "$" & KeyValues2.Address(False, False, xlA1) & "] AS T ON T.[Type] = A.[Type]"
' 筛选条件不变
With Application
  xStr = "'" & Join(.Transpose(.Index(vIncludeArr, 0, 1)), "','") & "'"
End With
strSQL = strSQL & " WHERE A.[segment] IN (" & xStr & ")"
' 排序逻辑不变
strSQL = strSQL & " ORDER BY G.ITEM, T.ITEM "

调整后后续不需要再遍历Recordset更新Groups字段，直接输出结果即可，删除原有Do While Not .EOF遍历更新的代码块即可。 #

方案2：Recordset更新后自定义排序（适合必须先修改Recordset的场景） #

如果你确实需要先在Recordset中处理数据再排序，可以通过新增临时排序字段实现：

1. 先把自定义排序规则读入字典方便快速查找
2. 给Recordset新增两个整数类型的临时排序字段
3. 更新Groups的同时给排序字段赋值
4. 按临时字段排序
   完整修改代码如下：

' =====在打开Recordset之前先把排序规则读入字典=====
Dim dictGroup As Object, dictType As Object
Set dictGroup = CreateObject("Scripting.Dictionary")
Set dictType = CreateObject("Scripting.Dictionary")
' 读取Groups排序规则（Status1）
For Each cell In KeyValues1.Columns(1).Cells
    If cell.Value <> "" Then dictGroup(cell.Value) = cell.Offset(0, 1).Value ' 第二列是排序序号
Next
' 读取Type排序规则（Status2）
For Each cell In KeyValues2.Columns(1).Cells
    If cell.Value <> "" Then dictType(cell.Value) = cell.Offset(0, 1).Value
Next

' =====打开Recordset之后新增临时字段=====
With oRec
    .CursorLocation = adUseClient
    .CursorType = adOpenDynamic
    .LockType = adLockOptimistic
    Set .ActiveConnection = oCon
    .Open (strSQL)
    Set .ActiveConnection = Nothing
    
    ' 新增临时排序字段
    .Fields.Append "GroupSort", adInteger
    .Fields.Append "TypeSort", adInteger
    
    ' 更新Groups和排序字段
    Do While Not .EOF
        For j = 1 To UBound(vIncludeArr, 1)
            If .Fields("segment").Value = vIncludeArr(j, 1) Then
                .Fields("Groups").Value = vIncludeArr(j, 2)
                ' 赋值Groups排序序号
                If dictGroup.Exists(vIncludeArr(j, 2)) Then
                    .Fields("GroupSort").Value = dictGroup(vIncludeArr(j, 2))
                Else
                    .Fields("GroupSort").Value = 999 ' 不在规则里的值放到最后
                End If
            End If
        Next
        ' 赋值Type排序序号
        If dictType.Exists(.Fields("Type").Value) Then
            .Fields("TypeSort").Value = dictType(.Fields("Type").Value)
        Else
            .Fields("TypeSort").Value = 999
        End If
        .MoveNext
    Loop
    
    ' 按自定义顺序排序
    .Sort = "GroupSort ASC, TypeSort ASC"
    
    ' 输出结果
    .MoveFirst
    shtSummaryOfData.Range("A2").CopyFromRecordset .DataSource
    .Close
End With

如果你的工程没有引用ADODB库，直接把常量替换为对应数值即可：adInteger = 3、adOpenDynamic = 2、adLockOptimistic = 3。

内容的提问来源于stack exchange，提问作者sifar