ListBox MultiSelect - moving selected items up the list

[RawlinsCross]

I have a listbox on a userform with several items in in. I'd like to be able to move them in groups up the list upon clicking a command button on the userform. Has anyone been through this challenge?

 

[Norie]

Where exactly do you want to move them?

Right to the top? Up one row?

Will the 'groups' be contiguous?

 

[RawlinsCross]

Good points Norie - I was thinking about the 'contiguous' angle after posting. But yes, they would be contiguous and reordered up one row as a block.

 

[Norie]

Give this a try.

Option Explicit

Private Sub cmdUp_Click()
Dim arrItems As Variant
Dim cnt As Long
Dim idx As Long
Dim idxTop As Long

    With ListBox1
        ReDim arrIndexItems(1 To .ListCount)
        ReDim arrItems(1 To .ListCount)
        For idx = .ListCount - 1 To 0 Step -1
            If .Selected(idx) Then
                idxTop = idx
                cnt = cnt + 1
                arrItems(cnt) = .List(idx, 0)
               .RemoveItem idx
            End If
        Next idx
    End With
    
    If idxTop <> 0 Then
        ReDim Preserve arrItems(1 To cnt)
        
        
        For idx = 1 To cnt
            With ListBox1
                .AddItem arrItems(idx), idxTop - 1
            End With
        Next idx
    End If
    
End Sub

Private Sub UserForm_Initialize()
Dim arr As Variant

    arr = Evaluate("""Item""&ROW(1:20)")
    With ListBox1
        .List = arr
        .MultiSelect = fmMultiSelectExtended
    End With
    
End Sub

 

[RawlinsCross]

Very good start - just dissecting the code now. Now if I wanted to maintain the highlighting in the event I want to keep clicking "UP" and by doing so keep moving the block up?

 

[Norie]

To keep the items selected you could try this, untested, adjustment to the code.

        For idx = 1 To cnt
            With ListBox1
                .AddItem arrItems(idx), idxTop - 1
                .Selected(idxTop-1) = True
            End With
        Next idx

 

[RawlinsCross]

Thanks, that did that trick! I also added at the top of the routine:

If .Selected(0) = True Then Exit Sub

If not, any contiguous selection that includes the first row will be deleted permanently.

 

[PetaT]

This work for me

Private Sub DownButton_Click()
Dim arrItems As Variant
Dim cnt As Long
Dim idx As Long
Dim idxTop As Long
Dim istop As Boolean

    With new_order
    Let istop = .selected(0)
    If .selected(.ListCount - 1) Then Exit Sub
        ReDim arrIndexItems(1 To .ListCount)
        ReDim arrItems(1 To .ListCount)
        For idx = .ListCount - 1 To 0 Step -1
            If .selected(idx) Then
                idxTop = idx
                cnt = cnt + 1
                arrItems(cnt) = .List(idx, 0)
               .RemoveItem idx
            End If
        Next idx
    End With
    
    If (idxTop <> 0) Or istop Then
        ReDim Preserve arrItems(1 To cnt)
        
        
        For idx = 1 To cnt
            With new_order
                .AddItem arrItems(idx), idxTop + 1
                .selected(idxTop + 1) = True
            End With
        Next idx
    End If
End Sub

Private Sub UPButton_Click()
Dim arrItems As Variant
Dim cnt As Long
Dim idx As Long
Dim idxTop As Long

    With new_order
        If .selected(0) Then Exit Sub
        ReDim arrIndexItems(1 To .ListCount)
        ReDim arrItems(1 To .ListCount)
        For idx = .ListCount - 1 To 0 Step -1
            If .selected(idx) Then
                idxTop = idx
                cnt = cnt + 1
                arrItems(cnt) = .List(idx, 0)
               .RemoveItem idx
            End If
        Next idx
    End With
    
    If idxTop <> 0 Then
        ReDim Preserve arrItems(1 To cnt)
        
        
        For idx = 1 To cnt
            With new_order
                .AddItem arrItems(idx), idxTop - 1
                .selected(idxTop - 1) = True
            End With
        Next idx
    End If
End Sub