Enabling Drag and Drop between two Listboxes on a VBA Userform

Content

Introduction
Updates
Working principle
The code

Introduction

One of the more difficult tasks in VBA programming is to enable drag and drop between two listboxes on a userform. There is an article on the Microsoft site about this that kind of gets you half-way there, but it does not work if you have the listbox setup to allow selecting more than one item. To make it easy to enable drag and drop between two listboxes on a userform I wrote a class module which you can simply insert into your VBA project. After doing that, it only takes about 8 lines of code to get it working.

This is what it looks like (tap on, or place mouse over image to see the animation):

Video showing drag and drop between two listboxes on a VBA userform

I have prepared a demo file for you!

Updates

9 March 2022: As of now, the class (see the new file in the download, file name TwoListboxDragDrop 7.xlsm) supports multi-column listboxes.

Working principle

If you want to implement Drag and Drop between controls (or within a control) on a userform, these control events are needed:

MouseMove

When the left mouse button is down while the mouse is moved, it is likely the user is starting a drag operation. We need to make sure the currently selected items of the list are remembered.

I want the code to enable drag and drop both between the two controls and within a control and I want to indicate where the drop will take place. I therefore need two things:

A way to remember which list items were selected when I started the drag

The code temporarily marks the items we're dragging by adding this bit of string in front of each selected item: "> ". This bit of string will later determine which items must be removed from the list after the drop has been done. If the user drags without a mousebutton held down, the "> " is removed from the list items to clean up.
A way to indicate the drop location

VBA does not make it easy to detect what list item is under the mouse cursor. The MouseMove and BeforeDropOrPaste events do give an X and Y coordinate, but determining which item "belongs" to a certain Y isn't easy as we do not know the Y coordinate of each item. The trick I used: temporarily add 40 list items to the listbox (to make sure the entire height of the box is used up by list items), then set the topindex of the listbox to the last one. This forces the listbox to scroll down, displaying the last item at the bottom of the listbox. The listbox then gets a new TopIndex (of the item actually displaying at the top) so we can now count how many items fit into the listbox' height. We can thus calculate the height of an individual item and use that to detect where our mouse is. You'll find the code that does this in the Property Set procedure belonging to ListBox1.
A way to scroll the listbox (up or down) if there are more items than the listbox can display in its height.

BeforeDragOver

The BeforeDragOver event is used to make sure the mouse pointer changes shape so the user has a visual indication whether or not he can drop items on that listbox. The class contains two boolean properties DragWithin1 and DragWithin2 which you can set to False if you want to disable drag withing either listbox.

BeforeDropOrPaste

This is where the magic happens, the code checks if there is anything to drop and if so, first adds the dragged items to the listbox and subsequently removes all marked items from the (other) listbox.

The code

Code needs to go in two places to enable drag and drop in your userform: In the code window behind the userform and in a separate class module called clsDragDrop you must insert into the VBAProject.

Userform

The userform has two listboxes (with their default names ListBox1 and ListBox2). All it takes to implement the drag and drop is these lines of code in the userform's code module:

Option Explicit

'Holds the instance of the drag and drop class
Private mcDragDrop As clsDragDrop

Private Sub UserForm_Initialize()
'------Start of lines just for our demo------
    Dim lCt As Long
    'Just add some items so we have something to drag
    With Me.ListBox1
        .ColumnCount = 2
        .ColumnWidths = .Width / 2.1 & "," & .Width / 2.1
        For lCt = 0 To 50
            .AddItem "Item " & lCt
            .List(.ListCount - 1, 1) = lCt
        Next
        .AddItem " "
    End With
    With Me.ListBox2
        .ColumnCount = 2
        .ColumnWidths = .Width / 2.1 & "," & .Width / 2.1
        For lCt = 60 To 100
            .AddItem "Item " & lCt
            .List(.ListCount - 1, 1) = lCt
        Next
        .AddItem " "
    End With
'------End of lines just for our demo------

    'Instantiate our class
    Set mcDragDrop = New clsDragDrop
    With mcDragDrop
        'Tell it which listboxes to work with
        Set mcDragDrop.ListBox1 = Me.ListBox1
        Set mcDragDrop.ListBox2 = Me.ListBox2
        'Enable drag and drop within both listboxes
        .DragWithin1 = True
        .DragWithin2 = True
        .DragIndicator = "> "
        .DropIndicator = "< "
    End With
End Sub

Note that the part between "Start of lines just for our demo" and "End of lines just for our demo" is only there to add some items to the listbox for demonstration purposes, you'd remove that or replace it with your own code that populates the listboxes on your form.

The clsDragDrop class

I decided to explain the code by inserting comments. I'm not adding more explanation here so I hope this is clear enough!

Note that most event routines are very short. They just contain a call to an associated method. This is because all aforementioned events come in pairs, one for each ListBox. The code for needed for each event is identical and hence private methods are called to handle them.

Here is the entire code inside the class module clsDragDrop, fully commented:

'---------------------------------------------------------------------------------------
' File   : clsDragDrop
' Author : Jan Karel Pieterse
' (c)    : Copyright JKP Application Development Services, all rights reserved
' Date   : 11-Jan-2022
' Purpose: Enable drag and drop between two listboxes
'---------------------------------------------------------------------------------------

Option Explicit

'Used to determine list item under mouse when dropping
Private mListItemCount As Long
Private mListItemSize As Double

Private Const LEFTMOUSEBUTTON As Long = 1

Private Const COLSEP As String = "¦"  'Chr(182) separator for the columns of a selected item we're dragging

Private WithEvents mListBox1 As msforms.listBox
Private WithEvents mListBox2 As msforms.listBox

'These two determine whether or not we are allowed to drag inside the controls:
Private mDragWithin1 As Boolean
Private mDragWithin2 As Boolean

Private mXStart As Single
Private mYstart As Single

Private mDragIndicator As String
Private mDropIndicator As String

'the listbox we dragged items from
Private mSourceBox As msforms.listBox
'the listbox we dragged items to
Private mTargetBox As msforms.listBox

Private Sub Class_Initialize()
    'Set defaults
    mDragWithin1 = False
    mDragWithin2 = False
End Sub

'---------------------Events---------------------

Private Sub Class_Terminate()
    Set mListBox1 = Nothing
    Set mListBox2 = Nothing
End Sub

Private Sub mListBox1_MouseMove(ByVal Button As Integer, _
                                 ByVal Shift As Integer, _
                                 ByVal X As Single, _
                                 ByVal Y As Single)
    HandleMouseMove mListBox1, Button, Shift, X, Y
    'MsgBox "NOTE TO SELF: HANDLE MULTI-COLUMN LISTBOXES!!"
End Sub

Private Sub mListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    mXStart = X
    mYstart = Y
End Sub

'Private Sub mListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'    FixSelectionAfterDrop mListBox1
'End Sub

Private Sub mListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    mXStart = X
    mYstart = Y
End Sub
'Private Sub mListBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'    FixSelectionAfterDrop mListBox2
'End Sub

Private Sub mListBox2_MouseMove(ByVal Button As Integer, _
                                 ByVal Shift As Integer, _
                                 ByVal X As Single, _
                                 ByVal Y As Single)

    HandleMouseMove mListBox2, Button, Shift, X, Y
End Sub

Private Sub mListBox1_BeforeDragOver(ByVal Cancel As msforms.ReturnBoolean, _
                                      ByVal Data As msforms.DataObject, _
                                      ByVal X As Single, _
                                      ByVal Y As Single, _
                                      ByVal DragState As msforms.fmDragState, _
                                      ByVal Effect As msforms.ReturnEffect, _
                                      ByVal Shift As Integer)

    HandleBeforeDragOver mListBox1, Cancel, Data, X, Y, DragState, Effect, Shift
End Sub

Private Sub mListBox2_BeforeDragOver(ByVal Cancel As msforms.ReturnBoolean, _
                                      ByVal Data As msforms.DataObject, _
                                      ByVal X As Single, _
                                      ByVal Y As Single, _
                                      ByVal DragState As msforms.fmDragState, _
                                      ByVal Effect As msforms.ReturnEffect, _
                                      ByVal Shift As Integer)

    HandleBeforeDragOver mListBox2, Cancel, Data, X, Y, DragState, Effect, Shift
End Sub

Private Sub mListBox1_BeforeDropOrPaste(ByVal Cancel As msforms.ReturnBoolean, _
                                         ByVal Action As msforms.fmAction, _
                                         ByVal Data As msforms.DataObject, _
                                         ByVal X As Single, _
                                         ByVal Y As Single, _
                                         ByVal Effect As msforms.ReturnEffect, _
                                         ByVal Shift As Integer)

    HandleBeforeDropOrPaste mListBox1, Cancel, Action, Data, X, Y, Effect, Shift
End Sub

Private Sub mListBox2_BeforeDropOrPaste(ByVal Cancel As msforms.ReturnBoolean, _
                                         ByVal Action As msforms.fmAction, _
                                         ByVal Data As msforms.DataObject, _
                                         ByVal X As Single, _
                                         ByVal Y As Single, _
                                         ByVal Effect As msforms.ReturnEffect, _
                                         ByVal Shift As Integer)

    HandleBeforeDropOrPaste mListBox2, Cancel, Action, Data, X, Y, Effect, Shift
End Sub

'---------------------Methods---------------------

Private Sub HandleMouseMove(ByRef localListbox As Object, _
                            ByVal Button As Integer, _
                            ByVal Shift As Integer, _
                            ByVal X As Single, _
                            ByVal Y As Single)
    Dim objData As DataObject
    Dim lEffect As Long
    Dim lCt As Long
    Dim lclicked As Long
    Dim sSelected As String
    Dim listCol As Long
    If Button = LEFTMOUSEBUTTON Then
        With localListbox
            'Detect on which item we last clicked
            'This is because if you first click 3 items and then initiate your drag by
            'clicking on the middle one, VBA unchecks the one you clicked on
            lclicked = .TopIndex + Int(Y / mListItemSize)
            If lclicked >= .ListCount Then lclicked = .ListCount
            If lclicked < 0 Then lclicked = 0
            For lCt = 0 To .ListCount - 1
                If (.Selected(lCt) Or lCt = lclicked) And Len(Trim(.List(lCt))) > 0 Then
                    .Selected(lCt) = False
                    'Build a list of the items we're about to drag
                    sSelected = sSelected & "|" & lCt & COLSEP & .List(lCt)
                    For listCol = 1 To .ColumnCount - 1
                        sSelected = sSelected & COLSEP & .List(lCt, listCol)
                    Next
                    'We add a small marker in front of each dragged item
                    'This provides a visual clue to the user which items he is dragging.
                    'In addition, it makes it easier to later recognize the ones that need to be removed from the listbox
                    'after the drop has been done
                    If Not .List(lCt) Like "[" & DragIndicator & "]*" Then
                        .List(lCt) = DragIndicator & .List(lCt)
                    End If
'                ElseIf lCt = lclicked Then
'                    'The one where we clicked might be deselected, but we always want to include that one with the drag
'                    sSelected = sSelected & "|" & lCt & ITEMSEP & .List(lCt)
'
'                    For listCol = 1 To .ColumnCount - 1
'                        sSelected = sSelected & COLSEP & .List(lCt, listCol)
'                    Next
'                    If Not .List(lCt) Like "[" & dragindicator & "]*" Then
'                        .List(lCt) = DragIndicator & .List(lCt)
'                    End If
                End If
            Next
            'If any items were selected, add them to the clipboard
            If Len(sSelected) > 0 Then
                Set mSourceBox = localListbox
                Set objData = New DataObject
                objData.SetText sSelected
                'Now initiate the actual drag
                lEffect = objData.StartDrag
            End If
        End With
    ElseIf Button = 0 And Not mTargetBox Is Nothing Then
        'clean up our temporarily added '> ' markings
        If mTargetBox Is localListbox Then FixSelectionAfterDrop mTargetBox
        With mTargetBox
            For lCt = .ListCount - 1 To 0 Step -1
                .Selected(lCt) = False
                If Left(.List(lCt), Len(DragIndicator)) = DragIndicator Or Left(.List(lCt), Len(DropIndicator)) = DropIndicator Then
                    .List(lCt) = Replace(.List(lCt), DragIndicator, "")
                    .List(lCt) = Replace(.List(lCt), DropIndicator, "")
                    .Selected(lCt) = True
                End If
            Next
        End With
        Set mTargetBox = Nothing
    ElseIf Button = 0 Then
        'clean up our temporarily added '> ' markings, needed when dragging within listbox is not allowed
        With localListbox
            For lCt = .ListCount - 1 To 0 Step -1
                If Left(.List(lCt), Len(DragIndicator)) = DragIndicator Or Left(.List(lCt), Len(DropIndicator)) = DropIndicator Then
                    .List(lCt) = Replace(.List(lCt), DragIndicator, "")
                    .List(lCt) = Replace(.List(lCt), DropIndicator, "")
                    .Selected(lCt) = True
                End If
            Next
        End With
    End If
End Sub

Private Sub HandleBeforeDragOver(localListbox As Object, _
                                 ByRef Cancel As msforms.ReturnBoolean, _
                                 ByRef Data As msforms.DataObject, _
                                 ByRef X As Single, _
                                 ByRef Y As Single, _
                                 ByRef DragState As msforms.fmDragState, _
                                 ByRef Effect As msforms.ReturnEffect, _
                                 ByRef Shift As Integer)
    Dim lTo As Long
    Dim lCt As Long

    Static prevTime As Double

    If Y = 0 Then Exit Sub    'Kludge to work around bug, sometimes Y is zero even when it shouldn't

    Cancel = True

    'This changes the mouse cursor to indicate whether drop is allowed
    If mSourceBox Is localListbox Then
        If localListbox.Name = Me.ListBox1.Name Then
            'We're in ListBox1, decide on dropeffect
            If DragWithin1 Then
                Effect = fmDropEffectMove
            Else
                Effect = fmDropEffectNone
            End If
        Else
            'We're in ListBox2, decide on dropeffect
            If DragWithin2 Then
                Effect = fmDropEffectMove
            Else
                Effect = fmDropEffectNone
            End If
        End If
    Else
        Effect = fmDropEffectMove
    End If
    If Effect = fmDropEffectNone Then Exit Sub
    With localListbox
        'Scroll listbox if we're close to the top and there are hidden items higher up
        If Y < CSng(mListItemSize / 2) Then
            If Timer - prevTime > 0.3 Then
                prevTime = Timer
                If .TopIndex > 0 Then
                    .TopIndex = .TopIndex - 1
                End If
            End If
        End If

        'Scroll listbox if we're close to the bottom and there are hidden items further down the list
        If Y > (.Height - mListItemSize * 0.7) Then
            If Timer - prevTime > 0.3 Then
                prevTime = Timer
                On Error Resume Next
                .TopIndex = .TopIndex + 1
                On Error GoTo 0
            End If
        End If
        'Indicate where we'll be pasting
        lTo = .TopIndex + Int(Y / mListItemSize)
        If lTo >= .ListCount Then lTo = .ListCount
'        If Len(Trim(.List(.ListCount - 1))) = 0 Then
'            lTo = .ListCount - 1
'        End If
        If lTo < 0 Then lTo = 0
        For lCt = 0 To .ListCount - 1
            If lCt = lTo Then
                .Selected(lCt) = True
            Else
                .Selected(lCt) = False
            End If
        Next
    End With
End Sub

Private Sub HandleBeforeDropOrPaste(localListbox As Object, _
                                    ByRef Cancel As msforms.ReturnBoolean, _
                                    ByRef Action As msforms.fmAction, _
                                    ByRef Data As msforms.DataObject, _
                                    ByRef X As Single, _
                                    ByRef Y As Single, _
                                    ByRef Effect As msforms.ReturnEffect, _
                                    ByRef Shift As Integer)
    Dim lTo As Long
    Dim lCt As Long
    Dim sSelected As String
    Dim vSel As Variant
    Dim vCols As Variant
    Dim listCol As Long

    If Abs(X - mXStart) < 2 And Abs(Y - mYstart) < 2 Then Exit Sub

    sSelected = Data.GetText
    vSel = Split(sSelected, "|")
    Cancel = True
    If Not mSourceBox Is localListbox Then
        'We arrive here when we drag from ListBox2 to ListBox1
        'Determine where we let go of our mouse, insert the items above this list item
        With localListbox
            lTo = .TopIndex + Int(Y / mListItemSize)
            If lTo >= .ListCount Then
                lTo = .ListCount
                If Len(Trim(.List(.ListCount - 1))) = 0 Then
                    lTo = .ListCount - 1
                End If
            End If
            If lTo < 0 Then lTo = 0
        End With
        'Add the dragged items at the indicated location
        AddItemsToBox localListbox, vSel, lTo
        Set mTargetBox = localListbox
        'Now delete the ones we dragged from the list
        With mSourceBox
            For lCt = .ListCount - 1 To 0 Step -1
                .Selected(lCt) = False
                If Len(Trim(.List(lCt))) > 0 And .List(lCt) Like "[" & DragIndicator & "]*" Then
                    .RemoveItem lCt
                End If
            Next
        End With
    ElseIf (DragWithin1 And mSourceBox Is mListBox1) Or (DragWithin2 And mSourceBox Is mListBox2) Then
        With localListbox
            'Now we're dragging within the same ListBox
            'Determine where we let go of our mouse, insert the items above this list item
            lTo = .TopIndex + Int(Y / mListItemSize)
            If lTo >= .ListCount Then
                lTo = .ListCount
                If Len(Trim(.List(.ListCount - 1))) = 0 Then
                    lTo = .ListCount - 1
                End If
            End If
            If lTo < 0 Then lTo = 0
            'Add the dragged items at the indicated location
            AddItemsToBox localListbox, vSel, lTo
            Set mTargetBox = localListbox
            'Now delete the ones we dragged from the list
            For lCt = .ListCount - 1 To 0 Step -1
                .Selected(lCt) = False
                If Len(Trim(.List(lCt))) > 0 And .List(lCt) Like "[" & DragIndicator & "]*" Then
                    .RemoveItem lCt
                End If
            Next
        End With
    End If
    Set mSourceBox = Nothing
End Sub

Private Sub AddItemsToBox(box2Add2 As msforms.listBox, vSel As Variant, lTo As Long)
    Dim vCols As Variant
    Dim listCol As Long
    Dim ct As Long

    With box2Add2
        For ct = UBound(vSel) To 1 Step -1
            vCols = Split(vSel(ct), COLSEP) 'vcols contains: ListIndex¦col 0¦col 1¦col 2¦......
            'Ignoring vCols(0) as that is the ListIndex, so we first add vCols(1) as a new item: "col 0"
            .AddItem DropIndicator & vCols(1), lTo
            'Now we add the remaining columns from vCols(2): "col 1", "col 2" and up as additional columns to this item of the listbox
            For listCol = 2 To UBound(vCols)
                .List(lTo, listCol - 1) = vCols(listCol)
            Next
        Next
    End With
End Sub
Private Sub FixSelectionAfterDrop(localListbox As Object)
    Dim lCt As Long
    Dim lbSource As msforms.listBox
    If localListbox Is mListBox1 Then
        Set lbSource = mListBox2
    Else
        Set lbSource = mListBox1
    End If
    With lbSource
        For lCt = 0 To .ListCount - 1
            .Selected(lCt) = False
        Next
    End With
End Sub
'---------------------Property let/set and gets---------------------

Public Property Get ListBox1() As msforms.listBox
    Set ListBox1 = mListBox1
End Property

Public Property Set ListBox1(ByVal oNewValue As msforms.listBox)
    Dim lCt As Long
    Set mListBox1 = oNewValue
    'The code below is used to temporarily fill the listbox with 40 items.
    'This is used to be able to determine which item of the list is under the mouse pointer when we drop
    With mListBox1
        For lCt = 1 To 40
            .AddItem lCt
        Next
        .TopIndex = .ListCount - 1
        mListItemCount = .ListCount - .TopIndex
        mListItemSize = .Height / mListItemCount
        For lCt = 1 To 40
            .RemoveItem .ListCount - 1
        Next
    End With
End Property

Public Property Get ListBox2() As msforms.listBox
    Set ListBox2 = mListBox2
End Property

Public Property Set ListBox2(ByVal oNewValue As msforms.listBox)
    Set mListBox2 = oNewValue
End Property

Public Property Get DragWithin1() As Boolean
    DragWithin1 = mDragWithin1
End Property

Public Property Let DragWithin1(ByVal bNewValue As Boolean)
    mDragWithin1 = bNewValue
End Property

Public Property Get DragWithin2() As Boolean
    DragWithin2 = mDragWithin2
End Property

Public Property Let DragWithin2(ByVal bNewValue As Boolean)
    mDragWithin2 = bNewValue
End Property

Public Property Get DragIndicator() As String
    DragIndicator = mDragIndicator
End Property

Public Property Let DragIndicator(ByVal sNewValue As String)
    mDragIndicator = sNewValue
End Property

Public Property Get DropIndicator() As String
    DropIndicator = mDropIndicator
End Property

Public Property Let DropIndicator(ByVal sNewValue As String)
    mDropIndicator = sNewValue
End Property

Comments

Showing last 8 comments of 9 in total (Show All Comments):

Comment by: Jan Karel Pieterse (15-6-2020 11:38:00) deeplink to this comment

Hi Rasa,

I'm not sure I understand what you mean, can you please try to explain with more detail?

Comment by: rasa (22-6-2020 10:07:00) deeplink to this comment

hi,
excuse me.i think this code is too long .its can be more simple.but i have 2 difficult question.please help me.

1)how to create a non boxes forms with vba in excel.
2)how to show 2 or more user forms together with vba in excel.

thanks,for support.

Comment by: Jan Karel Pieterse (22-6-2020 10:29:00) deeplink to this comment

Hi Rasa,

I'm interested to learn where my code could be shortened.

I'm not sure what you mean by a non-boxes form?

You can show two userforms as long as you make sure you show both using the vbModeless argument.

Comment by: Bryan (11-8-2020 03:39:00) deeplink to this comment

Hi Jan
Great article! Exactly what I was looking for. I've tweaked the code to fit our needs as we have a userform with 8 listboxes which we drag and drop between. Currently, it's only adding names to the bottom of lists and there was no way to reorder the list without emptying the contents and re-dragging items back into it in the correct order. Now they'll be able to drag and place items where they want in any box!

Further, I've added a function to try to clear the selected items after you paste them. So at the end of the HandleBeforeDropOrPaste function I have a call to the function like this:

ClearSelectedItemsAfterDrop moListBox1
ClearSelectedItemsAfterDrop moListBox2

And here's the function itself:

Private Sub ClearSelectedItemsAfterDrop(lb As ListBox)
    Dim litem As Long
    For litem = 0 To lb.ListCount
        If lb.Selected(litem) Then
            lb.Selected(litem) = False
        End If
    Next litem
End Sub

It's not perfect, but it's close and less distracting than having multiple blue selected items across multiple list boxes.

Thanks again for the great article!

Comment by: Jan Karel Pieterse (11-8-2020 10:07:00) deeplink to this comment

Hi Bryan,

You're welcome. And thanks for the code!

Comment by: David (18-1-2021 18:09:00) deeplink to this comment

Jan,

Thank you for building this code. It is very helpful. I'm using Office 365 and the following line did not work when I added more list boxes in the mix:

If .List(lCt) Like "[>] *" Then
.RemoveItem lCt
End If

So I changed:

If .List(lCt) Like "[>] *" Then
.List(lCt) = Replace(.List(lCt), "> ", "")
End If

To:

If .List(lCt) Like "[>] *" Then
.RemoveItem lCt
End If

Otherwise, great code. Thank You.

Comment by: Marcel (7-4-2021 13:07:00) deeplink to this comment

Hi, is this solution also working for TreeView Controls in Excel VBA?

Comment by: Jan Karel Pieterse (7-4-2021 13:34:00) deeplink to this comment

Hi Marcel,

I'm afraid not! But we do offer a paid treeview with drag and drop functionality for Excel VBA, please send us an email (address near bottom of this page) if you are interested in testing it.

Have a question, comment or suggestion? Then please use this form.

If your question is not directly related to this web page, but rather a more general "How do I do this" Excel question, then I advise you to ask your question here: www.eileenslounge.com.