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