Sort ADO Recordset Fields based on Custom Order-CodePudding

I have created an ADO Recordset from a Range of a Worksheet as shown below that I want to custom sort on Groups field, Then Type field. The Sort Order should be such that, the values of Groups column should be arranged in a custom order as given in another worksheet range column Status1 AND the values of Type column should be arranged in a custom order as given in another worksheet range column Status2 for e.g. :

 ==== =========== ================ 
|    |     A     |       B        |
 ==== =========== ================ 
| 1  | Type      | Groups         |
 ---- ----------- ---------------- 
| 2  | Restage 2 | Target Group 6 |
 ---- ----------- ---------------- 
| 3  | Restage 3 | Target Group 6 |
 ---- ----------- ---------------- 
| 4  | Restage 1 | Target Group 6 |
 ---- ----------- ---------------- 
| 5  | Current   | Target Group 6 |
 ---- ----------- ---------------- 
| 6  | Restage 1 | Target Group 4 |
 ---- ----------- ---------------- 
| 7  | Current   | Target Group 4 |
 ---- ----------- ---------------- 
| 8  | Restage 2 | Target Group 4 |
 ---- ----------- ---------------- 
| 9  | Restage 3 | Target Group 4 |
 ---- ----------- ---------------- 
| 10 | Restage 3 | Target Group 2 |
 ---- ----------- ---------------- 
| 11 | Restage 1 | Target Group 2 |
 ---- ----------- ---------------- 
| 12 | Restage 2 | Target Group 2 |
 ---- ----------- ---------------- 
| 13 | Current   | Target Group 2 |
 ---- ----------- ---------------- 
| 14 | Current   | Non Buyers     |
 ---- ----------- ---------------- 
| 15 | Restage 1 | Non Buyers     |
 ---- ----------- ---------------- 
| 16 | Restage 3 | Non Buyers     |
 ---- ----------- ---------------- 
| 17 | Restage 2 | Non Buyers     |
 ---- ----------- ---------------- 
| 18 | Current   | GP             |
 ---- ----------- ---------------- 
| 19 | Restage 3 | GP             |
 ---- ----------- ---------------- 
| 20 | Restage 2 | GP             |
 ---- ----------- ---------------- 
| 21 | Restage 1 | GP             |
 ---- ----------- ---------------- 
| 22 | Restage 2 | Buyers         |
 ---- ----------- ---------------- 
| 23 | Restage 1 | Buyers         |
 ---- ----------- ---------------- 
| 24 | Current   | Buyers         |
 ---- ----------- ---------------- 
| 25 | Restage 3 | Buyers         |
 ==== =========== ================

to like this:

 ==== =========== ================ 
|    |     A     |       B        |
 ==== =========== ================ 
| 1  | Type      | Groups         |
 ---- ----------- ---------------- 
| 2  | Current   | GP             |
 ---- ----------- ---------------- 
| 3  | Restage 1 | GP             |
 ---- ----------- ---------------- 
| 4  | Restage 2 | GP             |
 ---- ----------- ---------------- 
| 5  | Restage 3 | GP             |
 ---- ----------- ---------------- 
| 6  | Current   | Buyers         |
 ---- ----------- ---------------- 
| 7  | Restage 1 | Buyers         |
 ---- ----------- ---------------- 
| 8  | Restage 2 | Buyers         |
 ---- ----------- ---------------- 
| 9  | Restage 3 | Buyers         |
 ---- ----------- ---------------- 
| 10 | Current   | Non Buyers     |
 ---- ----------- ---------------- 
| 11 | Restage 1 | Non Buyers     |
 ---- ----------- ---------------- 
| 12 | Restage 2 | Non Buyers     |
 ---- ----------- ---------------- 
| 13 | Restage 3 | Non Buyers     |
 ---- ----------- ---------------- 
| 14 | Current   | Target Group 2 |
 ---- ----------- ---------------- 
| 15 | Restage 1 | Target Group 2 |
 ---- ----------- ---------------- 
| 16 | Restage 2 | Target Group 2 |
 ---- ----------- ---------------- 
| 17 | Restage 3 | Target Group 2 |
 ---- ----------- ---------------- 
| 18 | Current   | Target Group 4 |
 ---- ----------- ---------------- 
| 19 | Restage 1 | Target Group 4 |
 ---- ----------- ---------------- 
| 20 | Restage 2 | Target Group 4 |
 ---- ----------- ---------------- 
| 21 | Restage 3 | Target Group 4 |
 ---- ----------- ---------------- 
| 22 | Current   | Target Group 6 |
 ---- ----------- ---------------- 
| 23 | Restage 1 | Target Group 6 |
 ---- ----------- ---------------- 
| 24 | Restage 2 | Target Group 6 |
 ---- ----------- ---------------- 
| 25 | Restage 3 | Target Group 6 |
 ==== =========== ================

The Custom order of the both columns are to be picked up from 2 single-column Excel ranges (can be converted to Arrays) as shown below:

Status1:

 === ================ 
|   |       A        |
 === ================ 
| 1 | GP             |
 --- ---------------- 
| 2 | Buyers         |
 --- ---------------- 
| 3 | Non Buyers     |
 --- ---------------- 
| 4 | Target Group 1 |
 --- ---------------- 
| 5 | Target Group 2 |
 --- ---------------- 
| 6 | Target Group 3 |
 --- ---------------- 
| 7 | Target Group 4 |
 --- ---------------- 
| 8 | Target Group 5 |
 --- ---------------- 
| 9 | Target Group 6 |
 === ================

and :

Status2:

 ==== ============ 
|    |     A      |
 ==== ============ 
| 1  | Current    |
 ---- ------------ 
| 2  | Restage 1  |
 ---- ------------ 
| 3  | Restage 2  |
 ---- ------------ 
| 4  | Restage 3  |
 ---- ------------ 
| 5  | Restage 4  |
 ---- ------------ 
| 6  | Restage 5  |
 ---- ------------ 
| 7  | Restage 6  |
 ---- ------------ 
| 8  | Restage 7  |
 ---- ------------ 
| 9  | Restage 8  |
 ---- ------------ 
| 10 | Restage 9  |
 ---- ------------ 
| 11 | Restage 10 |
 ==== ============

For example, :

Set oRS = CreateObject("ADODB.Recordset")
....
With oRS
  .Sort = "Groups <customorder>,Types <customorder>"
End With

Does anyone knows how to do a Custom Order sort using a Recordset object?

EDIT:

@CDP1802 thanks for your reply! It works, but i overlooked something that i have to edit my post. Hope you can figure out how to handle it.

Initially the A.[Groups] column in the Base table is blank and I am updating it in the recordset based on values from another column [segment]. So the sorting is coming all wrong!

Here is a main snapshot of the code for your inspection:

' Grab `Groups` Filters from Study Details
With shtStudyDetails
  xLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
  If xLastRow <= 18 Then Exit Sub
  
  ' first check if `Assign` column has been filled in too
  Set xRg = .Range(.Cells(19, "B"), .Cells(xLastRow, "B"))
  If WorksheetFunction.CountA(xRg.Offset(0, 1).Cells) < WorksheetFunction.CountA(xRg.Cells) Then Exit Sub
  
  Set sRg = xRg.Resize(xRg.Rows.Count, 2)
  vArr = sRg.Value2
  
  ' Get Segment values excluding `Assign : Not Assigned`
  xStr = ""
  For j = 1 To UBound(vArr)
    If Not InStr(1, vArr(j, 2), "Not Assigned", vbTextCompare) > 0 Then xStr = xStr & "_" & j
  Next j
  If xStr = "" Then
    vIncludeArr = vArr
  Else
    vIncludeArr = Application.Index(vArr, Application.Transpose(Split(Mid(xStr, 2), "_")), Application.Transpose([row(1:2)]))
  End If
  If UBound(vIncludeArr) <= 1 And vIncludeArr(UBound(vIncludeArr), 1) = vbEmpty Then Exit Sub
    
  
  Set KeyValues1 = shtStudyDetails.Cells.Range("E45:F55") ' range1 table on whose values order to sort Groups
  Set KeyValues2 = shtStudyDetails.Cells.Range("G45:H106") ' range2 table on whose values order to sort Type

End With



With shtSummaryOfData
    xLastColumn = .Range("1:1").Cells(.Columns.Count).End(xlToLeft).Column
    If xLastColumn = 1 Then Exit Sub

    Set xRng = .Range(.Cells(1, 1), .Cells(1, xLastColumn))
    
    ' clear Summary of data sheet
    xLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
    If xLastRow < 2 Then Exit Sub
    
    .Range(.Cells(2, 1), .Cells(xLastRow, xLastColumn)).ClearContents

    strSQL = ""
    xStr = ""
    strSQL = "SELECT "
    
    For Each xCell In xRng
      With xCell
          xStr = xCell.Value2
          If InStr(1, xStr, " ", vbTextCompare) > 0 Then xStr = WorksheetFunction.Substitute(xStr, " ", " ")
          If InStr(1, xStr, ".", vbTextCompare) > 0 Then xStr = WorksheetFunction.Substitute(xStr, ".", "#")
      End With
      strSQL = strSQL & "A.[" & xStr & "],"
      
    Next xCell

    strSQL = Left(strSQL, Len(strSQL) - 1)
    strSQL = strSQL & " FROM (([" & shtPasteData.Name & "$" & xRg.Address(False, False, xlA1) & "] AS A "
    
    strSQL = strSQL & " LEFT JOIN [" & shtStudyDetails.Name & "$" & KeyValues1.Address(False, False, xlA1) & "] AS G ON G.[Groups] = A.[Groups])"
    strSQL = strSQL & " LEFT JOIN [" & shtStudyDetails.Name & "$" & KeyValues2.Address(False, False, xlA1) & "] AS T ON T.[Type] = A.[Type])"
    
    ' Join Segments in `vIncludeArr` that did not have Assign:Not Assigned
    With Application
      xStr = "'" & Join(.Transpose(.Index(vIncludeArr, 0, 1)), "','") & "'"
    End With
    strSQL = strSQL & " WHERE A.[segment] IN (" & xStr & ")"
    
    strSQL = strSQL & " ORDER BY G.ITEM, T.ITEM "

End With


Set oCon = CreateObject("ADODB.Connection")
Set oRec = CreateObject("ADODB.Recordset")

With oCon
    .Mode = adModeReadWrite
    .CursorLocation = adUseClient
    .Open Join$(Array("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & _
    sPath$ & ";Extended Properties=""Excel 12.0 Xml; HDR=YES;IMEX=0"";"), vbNullString)
End With

With oRec
    .CursorLocation = adUseClient
    .CursorType = adOpenDynamic
    .LockType = adLockOptimistic
    Set .ActiveConnection = oCon
    .Open (strSQL)
    
    Set .ActiveConnection = Nothing
    
    ' updating Groups column based on values in `vIncludeArr`
    Do While Not .EOF
        For j = 1 To UBound(vIncludeArr, 1)
          If .Fields("segment").Value = vIncludeArr(j, 1) Then .Fields("Groups").Value = vIncludeArr(j, 2)
        Next j
      .MoveNext
    Loop
  
  .MoveLast
  .MoveFirst
'  .Sort = .Fields("Groups").Name & " ASC," & .Fields("Type").Name & " ASC"
  
  .MoveLast
  .MoveFirst
  shtSummaryOfData.Range("A2").CopyFromRecordset .DataSource
  .Close
End With

And here is the Unique Segments Table which is used to populate the Blank Groups column with the Assigned Groups based on the unique Segment names:

╔══════════════════════╤════════════════╗
║ Segments             │ Assign Groups  ║
╠══════════════════════╪════════════════╣
║ ALL RESPONSES        │ GP             ║
╟──────────────────────┼────────────────╢
║ Some xx Target Group │ Target Group 1 ║
╟──────────────────────┼────────────────╢
║ Some Buyer1          │ Buyers         ║
╟──────────────────────┼────────────────╢
║ Some Non-Buyer1      │ Target Group 2 ║
╟──────────────────────┼────────────────╢
║ Some yy Target Group │ Target Group 3 ║
╟──────────────────────┼────────────────╢
║ Some zz Target Group │ Target Group 5 ║
╚══════════════════════╧════════════════╝

CodePudding user response：

Add an Item column to the 2 custom order tables then join them to the data table and use the Item fields in the sort orders.

Option Explicit

Sub test()

   Dim con As ADODB.Connection, sCon As String
   sCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & ThisWorkbook.FullName & ";" & _
           "Extended Properties='Excel 12.0 Macro;HDR=YES';"

   Set con = New ADODB.Connection
   With con
      .ConnectionString = sCon
      .Open
   End With
   
   Const SQL = " SELECT A.Type, A.Groups FROM (([Sheet1$] AS A" & _
               " LEFT JOIN [Sheet2$] AS T ON T.Type   = A.Type)" & _
               " LEFT JOIN [Sheet3$] AS G ON G.Groups = A.Groups)" & _
               " ORDER BY G.Item, T.Item"
               
   With Sheet4
       .Cells.Clear
       .Range("A1").CopyFromRecordset con.Execute(SQL)
   End With
   
End Sub