Home > database >  Sort a Range column based on the sequence of column values from another Range
Sort a Range column based on the sequence of column values from another Range

Time:11-11

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.

enter image description here

Sheet3 image

enter image description here

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
  • Related