ListBox Move Up/Down/Delete Multiple Rows

[jgspencer]

I have the below code that I use to move rows up or down in a control list box. The list box uses a named range for the data. Currently, if I move the selected row up, it only moves the row above the selection down and the same when I move the row down even if i select multiple rows. I want to be able to:

1. Move multiple rows up and move the row above the selection down below the selection.
2. Move multiple rows down and move the row below the selection up above the selection.
3. Clear or even delete the selected row or rows and move the below rows up.

I'm familiar with VBA but not real familiar on how to make this happen. The range I'm using has 20 rows. Any help would be greatly appreciated. Let me know if you need any more information.

Private Sub MoveDown_Click()
Dim lCurrentListIndex As Long
Dim strRowSource As String
Dim strAddress As String
Dim strSheetName As String
 
With ListBox1
  If .ListIndex < 0 Or .ListIndex = .ListCount - 1 Then Exit Sub
    lCurrentListIndex = .ListIndex + 1
    strRowSource = .RowSource
    strAddress = Range(strRowSource).Address
    strSheetName = Range(strRowSource).Parent.Name
    .RowSource = vbNullString
        With Range(strRowSource)
            .Rows(lCurrentListIndex).Cut
            .Rows(lCurrentListIndex + 2).Insert Shift:=xlDown
        End With
     Sheets(strSheetName).Range(strAddress).Name = strRowSource
    .RowSource = strRowSource
    .Selected(lCurrentListIndex) = True
End With
End Sub
 
 
Private Sub MoveUp_Click()
Dim lCurrentListIndex As Long
Dim strRowSource As String
Dim strAddress As String
Dim strSheetName As String
 
With ListBox1
  If .ListIndex < 1 Then Exit Sub
    lCurrentListIndex = .ListIndex + 1
    strRowSource = .RowSource
    strAddress = Range(strRowSource).Address
    strSheetName = Range(strRowSource).Parent.Name
    .RowSource = vbNullString
        With Range(strRowSource)
            .Rows(lCurrentListIndex).Cut
            .Rows(lCurrentListIndex - 1).Insert Shift:=xlDown
        End With
     Sheets(strSheetName).Range(strAddress).Name = strRowSource
    .RowSource = strRowSource
    .Selected(lCurrentListIndex - 2) = True
End With
End Sub

 

[MickG]

Hi, Glad to help , Good Idea with the Buttons !!
Regards Mick

 

[Snakehips]

My final post on this one.
Following a Move Up or Move Down, the original selection is now retained so that you can repeadedly jog your selection to any position without the need to keep re-selecting.
Also as requested by jgspencer, deleted rows will attract a fill word. 'I/D' rather than appear blank.

Tony

Private Sub MoveIt(Ans As String)

Dim TempA(1 To 20)
Dim TempB(1 To 20)

Dim Ray
Dim FirstSelectIndex As Integer
Dim A As Integer
Dim b As Integer
Dim Rw As Integer
Dim Temp As String
Dim Shift As Integer

With ListBox1

    For Rw = 0 To .ListCount - 1
        If .List(Rw) <> "" Then
        If .Selected(Rw) Then
        If FirstSelectIndex = 0 Then FirstSelectIndex = Rw
            A = A + 1
            TempA(A) = .List(Rw)
        Else
            b = b + 1
            TempB(b) = .List(Rw)
        End If
       End If
    Next Rw
 
If b <> 0 And A <> 0 Then
    If Ans = "Down" Then
        Ray = Application.Transpose(Range("A1").Resize(UBound(TempA)))
        Shift = 0
            For Rw = .ListCount - 2 To 0 Step -1
                If .List(Rw) <> "" Then
                    If .Selected(Rw) Then
                        Temp = Ray(Rw + 2)
                        Ray(Rw + 2) = .List(Rw)
                        Ray(Rw + 1) = Temp
                    End If
                End If
            Next Rw
            Range("A1").Resize(UBound(TempA)) = Application.Transpose(Ray)
    '*** Retain selection for Repeat of Down function
                .ListIndex = FirstSelectIndex
                For i = 1 To A
                Shift = A + 1
                If FirstSelectIndex + i + Shift - 1 = .ListCount Then Exit Sub
                .Selected(FirstSelectIndex - i + Shift) = True
                Next i
    ElseIf Ans = "Up" Then
    Ray = Application.Transpose(Range("A1").Resize(UBound(TempA)))
        Shift = -2
          For Rw = 1 To .ListCount - 1
                If .List(Rw) <> "" Then
                    If .Selected(Rw) Then
                        Temp = Ray(Rw)
                        Ray(Rw) = .List(Rw)
                        Ray(Rw + 1) = Temp
                    End If
                End If
            Next Rw
            Range("A1").Resize(UBound(TempA)) = Application.Transpose(Ray)
    '*** Retain selection for Repeat of Up function
                .ListIndex = FirstSelectIndex
                For i = 1 To A
                Shift = Shift + 2
                If FirstSelectIndex - i + Shift = 0 Then Exit Sub
                .Selected(FirstSelectIndex - i + Shift) = True
                Next i
    
    Else
        Columns("A:A").ClearContents
        If Ans = "Bottom" Then
            Range("A1").Resize(A) = Application.Transpose(TempA)
            Range("A1").Offset(A).Resize(b) = Application.Transpose(TempB)
        ElseIf Ans = "Top" Then
            Range("A1").Resize(b) = Application.Transpose(TempB)
            Range("A1").Offset(b).Resize(A) = Application.Transpose(TempA)
        ElseIf Ans = "Delete" Then
            Range("A1").Resize(b) = Application.Transpose(TempB)
        End If
    End If
End If
End With

' optional loop from bottom to fill blanks with deired fill word
'only following a delete
If Not Ans = "Delete" Then GoTo Out
i = 20
Do Until Not ActiveSheet.Cells(i, 1).Value = "" Or i = 0
ActiveSheet.Cells(i, 1).Value = "I/D"
i = i - 1
Loop

Out:

End Sub