I have a Range in a worksheet as shown below that I want to custom sort on Beta column from another worksheet range column Status:
--------- ---------- -----
| 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 |
--------- ---------- -----
like this:
--------- ---------- ---------
| 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 |
--------- ---------- ---------
based on unique values from another Range column:
----------
| STATUS |
----------
| PROGRESS |
----------
| PENDING |
----------
| COMPLETE |
----------
Is this possible using a custom sort function in VBA? e.g. something like below (not working):
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
CodePudding user response：
Please, test the next code. It assumes that the criteria range is in "A1:A4" of the "Sheet2" worksheet. The code will drop the processed result starting from "E2". If you like its return, please adapt the last code line in ws1.Range("A2"). It will overwrite the existing data:
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
Edited to prove no Match limitation for > 5000 rows:
Please, copy and run the next code:
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
It will raise no error for the maximum Excel number of rows...
Second edit:
A second (simpler) version, adding a helper column and sort according to it:
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
CodePudding user response：
How to use sql. The result is in a new 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 image
Create a new field Alpah2.
Sheet3 image
CodePudding user response：
Here is an extract of a simpler solution that i derived using 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