Excel VBA 2つのListview間でアイテムをドラッグ＆ドロップで移動したり、並べ替えたりする

Listviewから選択したアイテムをもう一つのListviewに加えたり、アイテムを任意の順に並べ替えられるようにします。複数選択やドラッグ＆ドロップも使えるようにします。

ユーザーフォームの見た目はこのような感じになります。

ソースコード

＜ユーザーフォームに書くコード＞

Private Sub UserForm_Initialize()

    Dim headers As String
        
        headers = _
                ",ID,30,0" & vbNewLine & _
                ",Name,70,0" & vbNewLine & _
                ",Mail,120,0"

    
    Call setLvHeaders(ListView1, headers, vbNewLine, ",")
    Call setLvHeaders(ListView2, headers, vbNewLine, ",")
    
    Dim contact(2, 2) As String
    
    contact(0, 0) = "1"
    contact(0, 1) = "John"
    contact(0, 2) = "john.d@gmail.com"
    contact(1, 0) = "2"
    contact(1, 1) = "Carole"
    contact(1, 2) = "carole-k@me.com"
    contact(2, 0) = "3"
    contact(2, 1) = "Peter"
    contact(2, 2) = "nobody@yahoo.com"
    
    
    Call setArray2Lv(Me.ListView1, contact)

End Sub
'Transfer selected items from Listview1 to ListView2
Private Sub ListView2_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    
    Call lv2Lv(Me.ListView1, Me.ListView2)

End Sub
'Transfer selected items from Listview2 to ListView1
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    
    Call lv2Lv(Me.ListView2, Me.ListView1)

End Sub

'Transfer selected items from Listview1 to ListView2
Private Sub cmd1To2_Click()
    
    Call lv2Lv(Me.ListView1, Me.ListView2)

End Sub
'Transfer selected items from Listview2 to ListView1
Private Sub cmd2To1_Click()

    Call lv2Lv(Me.ListView2, Me.ListView1)

End Sub
'Move selected items upward
Private Sub cmdUp1_Click()

    Call selectionMoveUp(ListView1)

End Sub
Private Sub cmdDown1_Click()

    Call selectionMoveDown(ListView1)

End Sub

'Move selected items upward
Private Sub cmdUp2_Click()
    
    Call selectionMoveUp(ListView2)

End Sub
'Move selected items downward
Private Sub cmdDown2_Click()

    Call selectionMoveDown(ListView2)

End Sub

＜標準モジュールに書くコード＞

'Set listview headers from delimited text
'(key,text,width,align)
Sub setLvHeaders(lv As MSComctlLib.ListView, _
                headers As String, _
                delimiter1 As String, _
                delimiter2 As String)
    
    With lv
    
        .View = lvwReport
        .LabelEdit = lvwManual
        .HideSelection = False
        .AllowColumnReorder = True
        .FullRowSelect = True
        .Gridlines = True
        .MultiSelect = True
        .HideColumnHeaders = False
        
        .OLEDragMode = ccOLEDragAutomatic
        .OLEDropMode = ccOLEDropManual
            
        .ColumnHeaders.Clear
        
        Dim tmp As Variant: tmp = Split(headers, delimiter1)
        
        Dim i As Long
        
        For i = LBound(tmp) To UBound(tmp)
            
            Dim header As Variant: header = Split(tmp(i), delimiter2)
            
            .ColumnHeaders.Add , header(0), header(1), header(2), header(3)
        
        Next
        

    End With
    
End Sub
'Set array to listview
Sub setArray2Lv(lv As MSComctlLib.ListView, srcArray As Variant)
    
    lv.listItems.Clear

    On Error GoTo errhandler
    
    Dim srcColCnt As Long: srcColCnt = UBound(srcArray, 2)
    
    GoTo nextStep
    
errhandler:
    
    If Err.Number = 9 Then srcColCnt = -1

nextStep:
    

    Dim row As Long, col As Long
    
    For row = 0 To UBound(srcArray, 1)
        
        With lv.listItems.Add
            
            If srcColCnt = -1 Then
                
                .Text = srcArray(row)
            
            Else
                
                .Text = srcArray(row, 0)
                
                If srcColCnt > 0 Then
                    
                    For col = 1 To srcColCnt
                        
                        If col > lv.ColumnHeaders.Count Then Exit For
                        
                        .subItems(col) = srcArray(row, col)
                    
                    Next
                End If
            
            End If
        
        End With
    
    Next

End Sub
'Transfer selected items between two listviews
Public Sub lv2Lv(srcLv As MSComctlLib.ListView, _
                destLv As MSComctlLib.ListView, _
                Optional deleteSrcItems As Boolean = True)
    
    If srcLv.listItems.Count < 1 Then Exit Sub
    
    Dim srcColCnt As Long: srcColCnt = srcLv.ColumnHeaders.Count
    Dim srcListItems As listItems: Set srcListItems = srcLv.listItems
    
    Dim i As Long
    
    'Array to store the indexes of selected list items
    ReDim idxArray(0)
    
    'Scan all the list items for selected ones
    For i = 1 To srcLv.listItems.Count
        
        If srcListItems(i).Selected = True Then
            
            idxArray(UBound(idxArray)) = srcListItems(i).Index
            
            ReDim Preserve idxArray(UBound(idxArray) + 1)
        
        End If
        
    Next

    If idxArray(0) = Empty Then Exit Sub
    
    'Remove the last element which is excessive
    If UBound(idxArray) > 0 Then ReDim Preserve idxArray(UBound(idxArray) - 1)
    
    'Remove the selected list items of the source list view
    ReDim srcArray(srcColCnt - 1, UBound(idxArray))
    
    Dim col As Long
    
    For i = 0 To UBound(idxArray)
    
        srcArray(0, i) = srcListItems(idxArray(i)).Text

        For col = 1 To srcColCnt - 1
            
            srcArray(col, i) = srcListItems(idxArray(i)).subItems(col)
        
        Next

    Next
    
    'Remove the selected list items of the source list view
    If deleteSrcItems Then
    
        For i = UBound(idxArray) To 0 Step -1
            srcLv.listItems.Remove idxArray(i)
        Next
    
    End If
    
    
    'Transfer items from source to destination
    For i = 0 To UBound(srcArray, 2)

        Dim foundText As Object: Set foundText = destLv.FindItem(srcArray(0, i))
        
        'If the same data is not found in the destination list view
        If foundText Is Nothing Then
            
            With destLv.listItems.Add
                
                .Text = srcArray(0, i)

                If srcColCnt > 1 Then
                    
                    For col = 1 To srcColCnt - 1
                        
                        If col > destLv.ColumnHeaders.Count Then Exit For
                        
                        .subItems(col) = srcArray(col, i)
                    
                    Next
                
                End If
            
            End With
        
        End If
    Next

    If srcLv.listItems.Count > 0 Then srcLv.listItems(1).Selected = True

End Sub

'Move upward selected item
Public Sub selectionMoveUp(lv As MSComctlLib.ListView)
    
    Dim itemCnt As Long: itemCnt = lv.listItems.Count
    
    If itemCnt < 1 Then Exit Sub
    If lv.SelectedItem.Index = 0 Then Exit Sub
    
    Dim subItemCnt As Long: subItemCnt = lv.listItems(1).ListSubItems.Count
    
    ReDim arraySubItems(subItemCnt)
    
    
    Dim row1 As Long, row2 As Long
    Dim subIdx As Long
    
    For row1 = 1 To itemCnt
    
        With lv.listItems(row1)
        
            If .Selected = True Then
                
                Dim txt As String: txt = .Text
                
                For subIdx = 1 To subItemCnt
                    
                    arraySubItems(subIdx) = .subItems(subIdx)
                
                Next
                
                row2 = .Index - 1
                
                If row2 < 1 Then Exit Sub
                
                lv.listItems.Remove (.Index)
                
                With lv.listItems.Add(row2)
                    
                    .Text = txt
                    
                    For subIdx = 1 To subItemCnt
                        
                        .subItems(subIdx) = arraySubItems(subIdx)
                    
                    Next
                    
                    .Selected = True
                
                End With
            
            End If
        
        End With
    
    Next

End Sub
'Move downward selected item
Public Sub selectionMoveDown(lv As MSComctlLib.ListView)
    
    Dim itemCnt As Long: itemCnt = lv.listItems.Count
    
    If itemCnt < 1 Then Exit Sub
        
    Dim subItemCnt As Long: subItemCnt = lv.listItems(1).ListSubItems.Count
    
    ReDim arraySubItems(subItemCnt)
    
    
    Dim row1 As Long, row2 As Long
    Dim subIdx As Long

    For row1 = itemCnt To 1 Step -1
    
        With lv.listItems(row1)
            
            If .Selected = True Then
                
                Dim txt As String: txt = .Text
                
                For subIdx = 1 To subItemCnt
                
                    arraySubItems(subIdx) = .subItems(subIdx)
                
                Next
                
                row2 = .Index + 1
                
                If row2 > itemCnt Then Exit Sub
                
                lv.listItems.Remove (.Index)
                
                With lv.listItems.Add(row2)
                    
                    .Text = txt
                    
                    For subIdx = 1 To subItemCnt
                        
                        .subItems(subIdx) = arraySubItems(subIdx)
                    
                    Next
                    
                    .Selected = True
                
                End With
            
            End If
        
        End With
    
    Next
    
End Sub