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
おまけ
Listviewはドラッグ&ドロップを(おそらく)唯一サポートしているコントロールです。工夫すれば他にも色々なことができます。