Custom Sorting Methods for End User?

[June7]

Until Orange provides what he has, review http://www.ozgrid.com/VBA/listbox-up-down.htm

Saving items of listbox as individual records requires code to iterate through the list and write records to table.

[kd2017]

That's correct.

Don't focus on the listbox, listbox doesn't matter, it could be a datasheet or multiple items subform. I'm looking for the best practice to use a sort column (field) by which a user can order a list of records.

[isladogs]

I did something similar to the suggestion by Orange a few months ago.
The code is part of a database I'm updating so it was close to hand
Apologies for treading on Orange's toes



The listbox is lstItinerary
The code for the Up/Down buttons is

Private Sub cmdDown_Click()

On Error GoTo Err_Handler


   If Me.LstItinerary.ItemsSelected.Count = 0 Then Exit Sub
   
    intStart = -1: intEnd = -1
    
    For Each itm In Me.LstItinerary.ItemsSelected
        If intStart < 0 Then intStart = itm
        If intEnd < 0 Then intEnd = itm
        
        If itm > intEnd + 1 Then
            MoveDown intStart, intEnd
            intStart = itm
        End If
        intEnd = itm


    Next
    
    MoveDown intStart, intEnd
    Me.LstItinerary.Requery
    
    itm = Null
    
Exit_Handler:
    Exit Sub
    
Err_Handler:
   FormattedMsgBox "Error " & Err.Number & " in cmdDown_Click procedure :             " & _
        "@" & Err.description & "            @", vbCritical, "Program error"
    Resume Exit_Handler
    
End Sub

Private Sub cmdUp_Click()

On Error GoTo Err_Handler


    If Me.LstItinerary.ItemsSelected.Count = 0 Then Exit Sub
   
    Dim intStart As Integer, intEnd As Integer
    intStart = -1: intEnd = -1
    For Each itm In Me.LstItinerary.ItemsSelected
        
        If intStart < 0 Then intStart = itm
        If intEnd < 0 Then intEnd = itm
        
        If itm > intEnd + 1 Then
            MoveUp intStart, intEnd
            intStart = itm
        End If
        intEnd = itm
        
        'Debug.Print intStart, intEnd


    Next
    MoveUp intStart, intEnd
    Me.LstItinerary.Requery
    
    itm = Null
    
Exit_Handler:
    Exit Sub
    
Err_Handler:
   FormattedMsgBox "Error " & Err.Number & " in cmdUp_Click procedure :             " & _
        "@" & Err.description & "            @", vbCritical, "Program error"
    Resume Exit_Handler


End Sub

These reference the MoveUp /MoveDown procedures
Some of the code is based on an example by AWF member static - not sure if he is also active on this forum under another name

Dim intStart As Integer, intEnd As Integer

Private Sub MoveUp(intStart As Integer, intEnd As Integer)


On Error GoTo Err_Handler


    If intStart <= 0 Or intEnd <= 0 Then Exit Sub
    
    CurrentDb.Execute "UPDATE tblRoutePlanner SET RouteOrderNo = (RouteOrderNo - 1)" & _
        " WHERE RouteOrderNo BETWEEN " & Me.LstItinerary.Column(1, intStart) & " AND " & Me.LstItinerary.Column(1, intEnd) & ";"
    
    CurrentDb.Execute "UPDATE tblRoutePlanner SET RouteOrderNo = " & Me.LstItinerary.Column(1, intEnd) + 1 & _
        " WHERE ID=" & Me.LstItinerary.Column(0, intStart - 1) & ";"
        
    Me.LstItinerary.Selected(intStart - 1) = True
    Me.LstItinerary.Selected(intEnd) = False
    
    intStart = -1
    intEnd = -1
    
Exit_Handler:
    Exit Sub
    
Err_Handler:
   FormattedMsgBox "Error " & Err.Number & " in MoveUp procedure :             " & _
        "@" & Err.description & "            @", vbCritical, "Program error"
    Resume Exit_Handler
    
End Sub


Private Sub MoveDown(intStart As Integer, intEnd As Integer)


On Error GoTo Err_Handler


    If intStart < 0 Or intEnd < 0 Then Exit Sub
    If intEnd + 1 > Me.LstItinerary.ListCount - 1 Then Exit Sub
    
   ' Debug.Print intStart, intEnd
    
    CurrentDb.Execute "UPDATE tblRoutePlanner SET RouteOrderNo = (RouteOrderNo + 1)" & _
        " WHERE RouteOrderNo BETWEEN " & Me.LstItinerary.Column(1, intStart) & " AND " & Me.LstItinerary.Column(1, intEnd) & ";"
    
    CurrentDb.Execute "UPDATE tblRoutePlanner SET RouteOrderNo = " & Me.LstItinerary.Column(1, intStart) - 1 & _
        " WHERE ID=" & Me.LstItinerary.Column(0, intEnd + 1) & ";"
        
    Me.LstItinerary.Selected(intStart) = False
    Me.LstItinerary.Selected(intEnd + 1) = True
    
    intStart = -1
    intEnd = -1
    
Exit_Handler:
    Exit Sub
    
Err_Handler:
   FormattedMsgBox "Error " & Err.Number & " in MoveDown procedure :             " & _
        "@" & Err.description & "            @", vbCritical, "Program error"
    Resume Exit_Handler
    
End Sub

[orange]

No issue at my end. Your example is right on target.

[kd2017]

I did something similar to the suggestion by Orange a few months ago.
The code is part of a database I'm updating so it was close to hand
Apologies for treading on Orange's toes

Thank you much for the example! So you went with pretty the strategy that was my first inclination. That's probably the way for me to go as well, the more I think about it doing this way would be simpler to implement than the second method I proposed.

@Orange, did you do yours in the the same way as ridders?

[orange]

Here is the code behind the buttons on the form.
My effort was simply to adapt some code I found to move a listbox item up/down.

Option Compare Database
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : Moveup_Click
' Author    : mellon
' Date      : 05/10/2015
' Purpose   :adapted from some Excel code I found.
'---------------------------------------------------------------------------------------
'
Private Sub Moveup_Click()
           '
           ' Move Items Up
           ' Allow multicolumn items to move
           '
          Dim lngIndex As Long
          Dim lngStarToRow As Long
          Dim blnSelected() As Boolean  'array to hold row was Selected info
           
10       On Error GoTo MOveup_Click_Error

20        With Listbox1
           
30            ReDim blnSelected(.ListCount) As Boolean

           'Record which row was selected
40            For lngIndex = 0 To .ListCount - 1
50                blnSelected(lngIndex) = .Selected(lngIndex)
60            Next
               
70            lngStarToRow = -1
             
             'determine which item(row) was selected
80            For lngIndex = 0 To .ListCount
90                If blnSelected(lngIndex) Then
100                   If lngStarToRow = -1 Then lngStarToRow = lngIndex
110               Else
120                   If lngStarToRow > 0 Then     'a row was selected
130                       SwapListboxItems Listbox1, lngStarToRow - 1, lngIndex - 1
140                       lngStarToRow = -1
150                   Else
160                       lngStarToRow = -1
170                   End If
180               End If
190           Next
200       End With

210      On Error GoTo 0
220      Exit Sub

MOveup_Click_Error:

230       MsgBox "Error " & Err.number & "  in Line (" & Erl & ")  " & Err.Description & ") in procedure MOveup_Click of VBA Document Form_formTestListBox"
           
End Sub

Private Sub MoveDown_Click()
'
' with Access Listbox.column(columnindex, row)
           '
           ' Move Items Down
           ' Allow multicolumn items to move
           '
          Dim lngIndex As Long
          Dim lngStarToRow As Long
          Dim blnSelected() As Boolean
10       On Error GoTo Movedown_Click_Error

20        With Listbox1
30            ReDim blnSelected(.ListCount) As Boolean
40            For lngIndex = 0 To .ListCount - 1
50                blnSelected(lngIndex) = .Selected(lngIndex)
60            Next
               
70            lngStarToRow = -1
80            For lngIndex = 0 To .ListCount - 1
90                If blnSelected(lngIndex) Then
100                   If lngStarToRow = -1 Then lngStarToRow = lngIndex
110               Else
120                   If lngStarToRow >= 0 Then
130                   SwapListboxItems Listbox1, lngIndex, lngStarToRow
140                       lngStarToRow = -1
150                   End If
160               End If
170           Next
180       End With

190      On Error GoTo 0
200      Exit Sub

Movedown_Click_Error:

210       MsgBox "Error " & Err.number & " in line " & Erl & "  (" & Err.Description & ") in procedure Movedown_Click of VBA Document Form_formTestListBox"
           
End Sub

Sub SwapListboxItems(Lst As ListBox, FromRow As Long, ToRow As Long)
'
' Swap the From Row and ToRow listbox items
'
10  On Error GoTo SwapListboxItems_Error

20  ReDim strSubItemText(Lst.ColumnCount - 1) As String  'array to store alpha/text
    Dim lngColumnIndex As Long
    Dim RowText As String               'to replace a multi column row

30  For lngColumnIndex = 0 To Lst.ColumnCount - 1
40      strSubItemText(lngColumnIndex) = Lst.Column(lngColumnIndex, FromRow)

50  Next
60  For lngColumnIndex = 0 To Lst.ColumnCount - 1
70      RowText = RowText & strSubItemText(lngColumnIndex) & ";"
80  Next
90  Lst.RemoveItem FromRow
100 Lst.AddItem RowText, ToRow

120 On Error GoTo 0
130 Exit Sub

SwapListboxItems_Error:

140 MsgBox "Error " & Err.number & "  in line  (" & Erl & ") " & Err.Description & "  in procedure SwapListboxItems of VBA Document Form_formTestListBox"

End Sub

[kd2017]

Here is the code behind the buttons on the form.
My effort was simply to adapt some code I found to move a listbox item up/down.

...

Sub SwapListboxItems(Lst As ListBox, FromRow As Long, ToRow As Long)
'
' Swap the From Row and ToRow listbox items
'

Doh, just swap sort order numbers of the neighboring records! So simple and straight forward it just might work!

[kd2017]

Inspired by you guy's I've come up with the following generic functions to accomplish this.

' Funtion: MoveUp
' ---------------
' Given a record's key this function will swap values in the SortField with another
'   record within the same table. The other record is located by finding the highest
'   SortField value less than the given record's SortField value where both records
'   have the same GroupField value.
'
' ID1: The ID of the record to move up
' tTable: The name of the table the records are in
' IDField: The name of the ID field of the table
' GroupField: The name of the field that relates rows that belong to the same group
' SortField: The name of the field that is used to sort records
'
' returns: True if successful, false if not successful

Public Function MoveUp(ID1 As Long, _
                        tTable As String, _
                        IDField As String, GroupField As String, SortField As String) As Boolean
On Error GoTo ErrHandler
    Dim rs As DAO.Recordset
    Dim qry As String
    
    MoveUp = False
    
    qry = "SELECT (" & _
          "  SELECT TOP 1 l2." & IDField & _
          "  FROM " & tTable & " AS l2" & _
          "  WHERE l2." & GroupField & " = l1." & GroupField & _
          "  AND l2." & SortField & " < l1." & SortField & _
          "  ORDER BY l2." & SortField & " DESC" & _
          ") AS ID2 " & _
          "FROM " & tTable & " AS l1 " & _
          "WHERE l1." & IDField & "=" & ID1 & ";"
          
    Set rs = CurrentDb.OpenRecordset(qry)
    
    If Not (rs.BOF And rs.EOF) Then
        If Not IsNull(rs.Fields(0)) Then
            SwapFieldValues ID1, rs.Fields(0), tTable, IDField, SortField
            MoveUp = True
        End If
    End If
    
    rs.Close
    
ExitHandler:
    Set rs = Nothing
    Exit Function
    
ErrHandler:
    Debug.Print "Error in MoveUp: #" & Err.Number & " " & Err.Description
    Resume ExitHandler
    
End Function

' Funtion: MoveDown
' -----------------
' Given a record's key this function will swap values in the SortField with another
'   record within the same table. The other record is located by finding the next highest
'   SortField value compared to the given record's SortField value where both records
'   have the same GroupField value.
'
' ID1: The ID of the record to move down
' tTable: The name of the table the records are in
' IDField: The name of the ID field of the table
' GroupField: The name of the field that relates rows that belong to the same group
' SortField: The name of the field that is used to sort records
'
' returns: True if successful, false if not successful

Public Function MoveDown(ID1 As Long, _
                          tTable As String, _
                          IDField As String, GroupField As String, SortField As String) As Boolean
On Error GoTo ErrHandler
    Dim rs As DAO.Recordset
    Dim qry As String
    
    MoveDown = False
    
    qry = "SELECT (" & _
          "  SELECT TOP 1 l2." & IDField & _
          "  FROM " & tTable & " AS l2" & _
          "  WHERE l2." & GroupField & " = l1." & GroupField & _
          "  AND l2." & SortField & " > l1." & SortField & _
          "  ORDER BY l2." & SortField & " ASC" & _
          ") AS ID2 " & _
          "FROM " & tTable & " AS l1 " & _
          "WHERE l1." & IDField & "=" & ID1 & ";"
          
    Set rs = CurrentDb.OpenRecordset(qry)
    
    If Not (rs.BOF And rs.EOF) Then
        If Not IsNull(rs.Fields(0)) Then
            SwapFieldValues ID1, rs.Fields(0), tTable, IDField, SortField
            MoveDown = True
        End If
    End If
    
    rs.Close
    
ExitHandler:
    Set rs = Nothing
    Exit Function
    
ErrHandler:
    Debug.Print "Error in MoveDown: #" & Err.Number & " " & Err.Description
    Resume ExitHandler
    
End Function

' Sub: SwapFieldValues
' --------------------
' Swaps the values in a single field between two rows from the same table.
' Expects the swaping field to allow null values.
'
' ID1: The ID value of the first record
' ID2: The ID value of the second record
' tTable: The name of the table the records are in
' IDField: The name of the ID field of the table
' SwapField: The name of the field that to be swapped between rows

Public Sub SwapFieldValues(ID1 As Long, ID2 As Long, _
                           tTable As String, _
                           IDField As String, SwapField As String)
On Error GoTo ErrHandler
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim sql As String
    Dim temp1 As Variant
    Dim temp2 As Variant
    
    sql = "SELECT " & SwapField & _
          " FROM " & tTable & _
          " WHERE " & IDField & " In (" & ID1 & ", " & ID2 & ");"
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sql, dbOpenDynaset)
    
    If Not (rs.BOF And rs.EOF) Then
        rs.MoveLast 'need to move last for recordcount
        temp2 = rs.Fields(0)
        rs.MoveFirst
        If rs.RecordCount = 2 Then
            temp1 = rs.Fields(0)
            rs.Edit
            rs.Fields(0) = Null
            rs.Update
            rs.MoveLast
            rs.Edit
            rs.Fields(0) = temp1
            rs.Update
            rs.MoveFirst
            rs.Edit
            rs.Fields(0) = temp2
            rs.Update
        End If
    End If
    
    rs.Close
    db.Close

ExitHandler:
    Set rs = Nothing
    Set db = Nothing
    Exit Sub
    
ErrHandler:
    Debug.Print "Error in SwapSortValues: #" & Err.Number & " " & Err.Description
    Resume ExitHandler
End Sub

They can simply be called like so:

Private Sub cmdDown_Click()
    If IsNull(Me.ListItems.Form!ID) Then Exit Sub
    If MoveDown(Me.ListItems.Form!ID, "ListItems", "ID", "ListID", "SortNumber") Then Me.ListItems.Requery
End Sub

Private Sub cmdUp_Click()
    If IsNull(Me.ListItems.Form!ID) Then Exit Sub
    If MoveUp(Me.ListItems.Form!ID, "ListItems", "ID", "ListID", "SortNumber") Then Me.ListItems.Requery
End Sub

Still needs testing, but just thought I'd share for critique and for anyone else in the future that might be in the same boat.

[ssanfu]

Years ago, I had to create a custom ordering form. I can't find the code now... but it was basically the same as orange; swap the Seq numbers. Worked well as long as the records numbers were than, say 15. 20 or more records was a LOT of clicking. Always wanted to be able to enter a number to move a record to, but never got around to it.


I am going to "borrow" (steal??) the examples from all 3 of you. No sense in re-inventing the wheel....

[kd2017]

Worked well as long as the records numbers were than, say 15. 20 or more records was a LOT of clicking.

That's a good point. Also it brings up another related question I had. Anyone aware of any activex controls with drag-drop type functionality that might be useful here? Cheap would be preferable.

[isladogs]

My code (based on static's ideas) uses a multiselect listbox so that you can move several items in one click
E.g if you want to move items 3, 4 and 6 above item 2, select the 3 rows and click move up.
Click again to move all three to the top

Kd2017
I've not tried your code
Why would you want an activeX control here?
They are best avoided as they can cause issues on different setups

[kd2017]

My code (based on static's ideas) uses a multiselect listbox so that you can move several items in one click
E.g if you want to move items 3, 4 and 6 above item 2, select the 3 rows and click move up.
Click again to move all three to the top

That could be very handy

Kd2017
I've not tried your code
Why would you want an activeX control here?
They are best avoided as they can cause issues on different setups

Activex is not important, I was just thinking it would be nice if we could figure out a way to drag-and-drop items to reorder them.

[isladogs]

Activex is not important, I was just thinking it would be nice if we could figure out a way to drag-and-drop items to reorder them.

It would be nice - drag & drop in access is limited & in general not easy to do

[ArviLaanemets]

About saving the sort order with multiple users:

Don't save the sort order into original table, but have instead a special tblSortOrder: SOID, UserID, TableID, SortOrder.

When user wants to edit the sort order, the tblSortOrder must be opened in subform linked to unbound control containing UserID - so all new entries will have UserID of this particular user.
Whe user opens report, the tblSortOrder is linked to main table (tblSortOrder.TableID = MainTable.TableID) and filtered by UserID.

I.e. every user has his/her own set of order numbers for every row of main table.

This doesn't mean I myself will ever to do something like this

[kd2017]

I.e. every user has his/her own set of order numbers for every row of main table.

This doesn't mean I myself will ever to do something like this

That's definitely not the goal of the original post but maybe useful to others in the future. Thank you!