根据另一个范围的列值序列对范围列进行排序
Sort a Range column based on the sequence of column values from another Range
我在工作表中有一个范围，如下所示，我想在另一个工作表范围列 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 |
+---------+----------+---------+
基于另一个范围列的唯一值：
+----------+
| 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
请测试下一个代码。它假定 条件范围位于“Sheet2”工作表的“A1:A4”中。该代码将丢弃从“E2”开始的处理结果。如果您喜欢它的 return，请修改 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
如何使用sql。结果在新的 sheet 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 图片
这是我使用 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
我在工作表中有一个范围，如下所示，我想在另一个工作表范围列 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 |
+---------+----------+---------+
基于另一个范围列的唯一值：
+----------+
| 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
请测试下一个代码。它假定 条件范围位于“Sheet2”工作表的“A1:A4”中。该代码将丢弃从“E2”开始的处理结果。如果您喜欢它的 return，请修改 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
如何使用sql。结果在新的 sheet 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 图片
这是我使用 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