根据来自另一个 Range 的列值序列对 Range 列进行排序答案

【问题标题】：Sort a Range column based on the sequence of column values from another Range根据来自另一个 Range 的列值序列对 Range 列进行排序
【发布时间】：2021-12-22 23:24:05
【问题描述】：

我在工作表中有一个范围，如下所示，我想对另一个工作表范围列 Status 中的 Beta 列进行自定义排序：

+---------+----------+-----+
| Alpha   | Beta     | Gama|
+---------+----------+-----+
| PROJ 1  | COMPLETE | 245 |
+---------+----------+-----+
| PROJ 2  | PENDING  | 344 |
+---------+----------+-----+
| PROJ 3  | COMPLETE | 122 |
+---------+----------+-----+
| PROJ 4  | COMPLETE | 111 |
+---------+----------+-----+
| PROJ 5  | PENDING  | 101 |
+---------+----------+-----+
| PROJ 6  | PENDING  | 222 |
+---------+----------+-----+
| PROJ 7  | PROGRESS | 343 |
+---------+----------+-----+
| PROJ 8  | PROGRESS | 256 |
+---------+----------+-----+
| PROJ 9  | PROGRESS | 606 |
+---------+----------+-----+
| PROJ 10 | COMPLETE | 234 |
+---------+----------+-----+

像这样：

+---------+----------+---------+
| Alpha   | Beta     | Gama    |
+---------+----------+---------+
| PROJ 7  | PROGRESS | 343     |
+---------+----------+---------+
| PROJ 8  | PROGRESS | 256     |
+---------+----------+---------+
| PROJ 9  | PROGRESS | 606     |
+---------+----------+---------+
| PROJ 2  | PENDING  | 344     |
+---------+----------+---------+
| PROJ 5  | PENDING  | 101     |
+---------+----------+---------+
| PROJ 6  | PENDING  | 222     |
+---------+----------+---------+
| PROJ 1  | COMPLETE | 245     |
+---------+----------+---------+
| PROJ 3  | COMPLETE | 122     |
+---------+----------+---------+
| PROJ 4  | COMPLETE | 111     |
+---------+----------+---------+
| PROJ 10 | COMPLETE | 234     |
+---------+----------+---------+

基于另一个 Range 列的唯一值：

+----------+
| STATUS   |
+----------+
| PROGRESS |
+----------+
| PENDING  |
+----------+
| COMPLETE |
+----------+

这是否可以在 VBA 中使用自定义排序功能？例如类似下面的东西（不工作）：

Sub SortTable()

Dim rng1 As Range, rng2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")

With ws1
  Set rng1 = .Range(.Cells(1, 1), .Cells(11, 3))
End With

With ws2
  Set rng2 = .Range(.Cells(1, 1), .Cells(4, 3))
End With
  
With rng1.Sort
    .SortFields.Add Key:=rng2.ListColumns("Status").Range, Order:=xlAscending
    .Header = xlYes
    .Apply
End With

End Sub

【问题讨论】：

“来自另一个 Range 列的唯一值”是什么意思？是否在您向我们展示的范围内，或者有很多出现并且代码应该提取唯一的？那么，rng2 是否会成为您代码中的排序标准范围？
Rng2 是一个唯一值范围列表，在Rng1 的Beta 列中具有匹配值。使用该顺序（序列），Rng1 列 (Beta) 需要进行排序。
在PROJ 3和PROJ 10中，优先级是PROJ 10。这是一个字符，所以10比3快。需要改变数据的格式。比较 3 和 10，10 更快。比较03和10，03是最快的排名。
对不起，我不明白。这个想法只是按照Rng2 中给出的顺序对Beta 列值进行排序。
如果Alpha字段是3，10是一个数字，优先级是3 快，但是后面有一个数字和字母混在一起，所以你得把它看成一个字母作为一个整体。在这种情况下，按排序顺序将 3 放在 10 之后。这意味着您必须将数字格式更改为 03,10，或者如果单位较大，则更改为 003, 010 以确保正确对齐。

标签： excel vba sorting range

【解决方案1】：

请测试下一个代码。它假定条件范围在“Sheet2”工作表的“A1:A4”中。该代码将从“E2”开始删除处理结果。如果您喜欢它的返回，请修改ws1.Range("A2") 中的最后一行代码。它将覆盖现有数据：

Sub SortTable()
 Dim ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, k As Long
 Dim Dim rngC As Range, arrL, arr, arrFin, mtch, dict As Object, arrL, arr, arrFin, mtch, dict As Object

 Set ws1 = ThisWorkbook.Worksheets("Sheet1")
 Set ws2 = ThisWorkbook.Worksheets("Sheet2")

 With ws1
    arrL = .Range(.cells(2, 1), .cells(11, 3)).value 'place the range in an array for faster iteration
 End With

 With ws2
     Set rngC = .Range(.cells(2, 1), .cells(4, 1))
 End With

 ReDim arrFin(1 To UBound(arrL), 1 To UBound(arrL, 2)) 'redim the final array
 Set dict = CreateObject("scripting.Dictionary")
 For i = 1 To UBound(arrL) 'create unique keys in the dictionary and add the necessary information separated by "|" and "::"
     dict(arrL(i, 2)) = dict(arrL(i, 2)) & "|" & arrL(i, 1) & "::" & arrL(i, 3)
 Next i

 For i = 1 To rngC.rows.count
    mtch = Application.match(rngC(i, 1).value, dict.Keys, 0)
    arrL = Split(Mid(dict.items()(mtch - 1), 2), "|")
    For j = 0 To UBound(arrL)
        arr = Split(arrL(j), "::")
        k = k + 1
        arrFin(k, 1) = arr(0): arrFin(k, 2) = dict.Keys()(mtch - 1): arrFin(k, 3) = arr(1)
    Next
 Next i
 'drop the processed array content at once:
 ws1.Range("E2").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub

已编辑以证明 > 5000 行没有匹配限制：

请复制并运行下一个代码：

Sub testMatchLimitations()
 Dim sh As Worksheet, mtch, arr
 Set sh = ActiveSheet
 sh.Range("C1:C2").value = Application.Transpose(Array("AAA1", "AAA2"))
 
 sh.Range("C1:C2").AutoFill Destination:=sh.Range("C1:C" & sh.rows.count), Type:=xlFillDefault
 arr = sh.Range("C1:C" & sh.rows.count).value
 mtch = Application.match("AAA1048566", arr, 0)
  Debug.Print mtch
End Sub

它将引发Excel 的最大行数没有错误...

第二次编辑：

第二个（更简单的）版本，添加一个辅助列并根据它进行排序：

Sub SortTable_1()
 Dim ws1 As Worksheet, ws2 As Worksheet, i As Long
 Dim rngC As Range, lastR As Long, lastCol As Long, arrL, arrFin, mtch

 Set ws1 = ActiveSheet ' ThisWorkbook.Worksheets("Sheet1")
 Set ws2 = ws1.Next ' ThisWorkbook.Worksheets("Sheet2")
 lastR = ws1.Range("A" & ws1.rows.count).End(xlUp).row
 lastCol = 4 'it can be calculated...
 With ws1
    arrL = .Range(.cells(2, 1), .cells(lastR, 3)).value
 End With

 With ws2
    Set rngC = .Range(.cells(2, 1), .cells(4, 1))
 End With
 ReDim arrFin(1 To UBound(arrL), 1 To 1)
 For i = 1 To UBound(arrL)
    mtch = Application.match(arrL(i, 2), rngC, 0)
    If Not IsError(mtch) Then
        arrFin(i, 1) = mtch
    Else
        MsgBox "There is no match in the criteria range for value in C" & i + 1 & "(" & arrL(i, 2) & "...": Exit Sub
    End If
 Next i
 
 ws1.cells(1, lastCol).value = "Rank"
 ws1.cells(2, lastCol).Resize(UBound(arrFin), 1).value = arrFin
 ws1.Range("A1", ws1.cells(lastR, lastCol)).Sort key1:=ws1.Range("D1"), Order1:=xlAscending, Header:=xlYes
 ws1.cells(1, lastCol).EntireColumn.Delete
End Sub

【讨论】：

我认为有比使用字典和数组更简单的方法。代码虽然很大，但对（我认为 mtch=Application.match(arrC(i), dict.Keys, 0) 会失败。
@sifar 为什么会失败？仅当条件范围元素与“Beta”列中使用的字符串之间存在差异时，才会发生这种情况。或者你错误地声明了mtch。也许那里有一些额外的空间......如果是这种情况，则可以调整代码以修剪使用的元素。你的工作簿中发生过这种情况吗？如果是这样，如果不是机密信息，您可以分享吗？即使有虚拟数据......哪个是“更简单的方法”？我有不同的想法，但我很好奇你的想法...... :) 我只玩过 VBA。
我并不是说它不起作用。但通过经验，我发现它对于更大的数据不可靠......甚至是 VBA.Filter 或 Application.Index 等。
@sifar 你试过上面的代码了吗？如果是这样，它会在该行出错时停止，将光标移动到arrC(i)，它会显示什么？你没有说任何关于工作簿共享的事情......
我无法共享，因为我正在将代码直接写入企业帐户的共享点工作簿中。一旦我创建了一个填充了更大数据集的虚拟文件，我肯定会尝试它（即使您可以尝试共享一个）。

【解决方案2】：

如何使用sql。结果在新工作表 Sheet3 中。

Sub DoSQL(Ws As Worksheet, strSQL As String)
 
    Dim Rs As Object
    Dim strConn As String
    Dim i As Integer
 
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=Excel 12.0;"
 
 
    Set Rs = CreateObject("ADODB.Recordset")
    Rs.Open strSQL, strConn
 
    If Not Rs.EOF Then
         With Ws
            .Range("a1").CurrentRegion.ClearContents
            For i = 0 To Rs.Fields.Count - 1
               .Cells(1, i + 1).Value = Rs.Fields(i).Name
            Next
            .Range("a" & 2).CopyFromRecordset Rs
        End With
    End If
    Rs.Close
    Set Rs = Nothing
End Sub
Sub test()
    Dim strSQL As String
    Dim Ws As Worksheet
    Dim Ws1 As Worksheet
    Dim vDB, vS
    Dim i As Long
    
    Set Ws1 = Sheets("Sheet1")
    With Ws1
        vDB = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
    End With
    For i = 1 To UBound(vDB, 1)
        vS = Split(vDB(i, 1))
        vDB(i, 1) = vS(0) & " " & Format(Val(vS(1)), "000#")
    Next i
    With Ws1
        .Range("d1") = "Alpha2"
        .Range("d2").Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
    End With
    
    Set Ws = Sheets("Sheet3")
    
    strSQL = "select a.Alpha, Beta, Gama "
    strSQL = strSQL & "FROM "
    strSQL = strSQL & "( select * from [Sheet1$]  , [Sheet2$] as b "
    strSQL = strSQL & "where beta = b.status ) as a "
    strSQL = strSQL & "ORDER BY b.status desc, a.Alpha2 "

    DoSQL Ws, strSQL
End Sub

Sheet1 图片

创建一个新字段Alpah2。

Sheet3 图片

【讨论】：

我之前尝试过使用 ADO，但发现如果工作簿存储在云中，它无法在 Excel 365 中正常工作，例如Onedrive 或 Sharepoint。它会导致问题的行是ThisWorkbook.FullName，它可能会给出一个ADO 无法翻译的https:// 地址。所以不得不求助于向后兼容的代码。
@sifar，对不起，我也不知道这部分。

【解决方案3】：

这是我使用CustomLists 推导出的更简单解决方案的摘录。

Sub SortRange()
.....

'Custom Sort `Rng1`
xLastColumn = .Range("1:1").Cells(.Columns.Count).End(xlToLeft).Column
xLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row

KeyValues = wk3.Cells.Range("F46:F54").Value2 ' `Rng2
n = Application.GetCustomListNum(KeyValues)
Application.DeleteCustomList n
            
Application.AddCustomList listArray:=KeyValues
sortNumber = Application.CustomListCount
            
wk2.Sort.SortFields.Clear
            
wk2.Sort.SortFields.Add _
  Key:=wk2.Range(yCell.Offset(1, 0), wk2.Cells(xLastRow, yCell.Column)), _
  SortOn:=xlSortOnValues, _
  Order:=xlAscending, _
  CustomOrder:=sortNumber, _
  DataOption:=xlSortNormal
          
  With wk2.Sort
    .SetRange wk2.Range(wk2.Cells(1, 1), wk2.Cells(xLastRow, xLastColumn))
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
End With

.....

End Sub

【讨论】：