| |
>できないのが、左側で選択したデータを右側リストの選択されているリスト行に
>追加するやりかたです。
これは、右のListBoxで選択された行を、左のListBoxに戻すということですか？
例えば、WorkSheets("Sheet1")に以下の様なデータが有るとします
Ａ Ｂ
１ 商品Ａ １００円
２ 出張費 ５００円
３ 商品Ｂ ２００円
４ 商品Ｃ ３００円
５ ・・
UserFormに、以下のコントロールを配置して下さい
ListBox1：左のListBox
ListBox2：右のListBox
CommandButton1：右に追加
CommandButton2：左に戻す
動きは、Listをダブルクリックするか、Listを選択してCommandButtonを押します
左のBoxから右のBoxへ追加する場合は、移した順番に成ります
右のBoxから左のBoxへ戻す場合は、元の順番に成ります
'ListBox1からListBox2へは、後に追加されます
'ListBox2からListBox1へは、元の位置に追加されます
以下を、UserFormのコードモジュールに記述して下さい
Option Explicit
Option Compare Text
Private vntLinear As Variant
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
MoveItems ListBox1, ListBox2
End Sub
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
MoveItems ListBox2, ListBox1, True
End Sub
Private Sub UserForm_Initialize()
' Dim i As Long
Dim vntList As Variant
With ListBox1
'ListBoxに２列表示の場合、以下を活かす
' .ColumnCount = 2
'TagにListBox1を示す番号を設定
.Tag = 1
'マルチセレクトに設定
.MultiSelect = fmMultiSelectExtended
'Listを取得して、ListのTablを作成
'以下の行で「WorkSheets("Sheet1").Cells(1, "A")」は、
'ListBoxで表示するデータ先頭セル位置を指定
If CreateList(vntList, vntLinear, Worksheets("Sheet1").Cells(1, "A")) Then
.List = vntList
.ListIndex = 0
End If
End With
With ListBox2
'ListBoxに２列表示の場合、以下を活かす
' .ColumnCount = 2
.Tag = 2
.MultiSelect = fmMultiSelectExtended
End With
Me.Caption = "リストボックス間でデータ移動"
End Sub
Private Sub CommandButton1_Click()
MoveItems ListBox1, ListBox2
End Sub
Private Sub CommandButton2_Click()
MoveItems ListBox2, ListBox1, True
End Sub
Private Function CreateList(vntItems As Variant, _
vntTable As Variant, _
rngData As Range) As Boolean
Dim i As Long
Dim lngRows As Long
With rngData
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データが無い場合は、Functionを抜ける
If lngRows <= 0 Then
Exit Function
End If
'データを配列に取得
'ListBoxに２列表示の場合、此方を使用
' vntItems = .Resize(lngRows, 2).Value
'ListBoxに１列表示の場合、此方を使用
vntItems = .Resize(lngRows, 1).Value
End With
'LinearListの作成
ReDim vntTable(UBound(vntItems, 1), 2)
vntTable(0, 1) = 1
vntTable(0, 2) = -1
For i = 1 To lngRows
vntTable(i, 0) = vntItems(i, 1)
vntTable(i, 2) = -1
If i = lngRows Then
vntTable(i, 1) = -1
Else
vntTable(i, 1) = i + 1
End If
Next i
CreateList = True
End Function
Private Sub MoveItems(lstFrom As MSForms.ListBox, _
lstTo As MSForms.ListBox, _
Optional blnKeep As Boolean = False)
Dim i As Long
Dim j As Long
Dim vntList() As Variant
Dim lngPos As Long
j = 0
With lstFrom
For i = 0 To .ListCount - 1
If .Selected(i) Then
j = j + 1
ReDim Preserve vntList(1 To j)
vntList(j) = i
lngPos = ListSearch(.List(i, 0), _
CLng(lstTo.Tag), blnKeep)
If lstTo.ListCount - 1 < lngPos Then
lstTo.AddItem .List(i, 0)
'ListBoxに２列表示の場合、以下を活かす
' lstTo.List(lstTo.ListCount - 1, 1) = .List(i, 1)
Else
lstTo.AddItem .List(i, 0), lngPos
'ListBoxに２列表示の場合、以下を活かす
' lstTo.List(lngPos, 1) = .List(i, 1)
End If
End If
Next i
If j > 0 Then
For i = UBound(vntList) To 1 Step -1
.RemoveItem vntList(i)
Next i
End If
End With
End Sub
Private Function ListSearch(vntKey As Variant, _
lngTo As Long, _
Optional blnKeep As Boolean = False) As Long
Dim i As Long
Dim lngOrder As Long
Dim lngOld As Long
Dim lngFrom As Long
Dim lngPos As Long
lngFrom = (lngTo Mod 2) + 1
lngOrder = 0
lngOld = 0
Do Until vntLinear(lngOld, lngFrom) = -1
lngOrder = vntLinear(lngOld, lngFrom)
If vntLinear(lngOrder, 0) = vntKey Then
vntLinear(lngOld, lngFrom) _
= vntLinear(lngOrder, lngFrom)
vntLinear(lngOrder, lngFrom) = -1
Exit Do
Else
lngOld = lngOrder
End If
Loop
lngOld = 0
lngPos = 0
Do Until vntLinear(lngOld, lngTo) = -1
If blnKeep Then
If lngOld < lngOrder Then
If lngOrder < vntLinear(lngOld, lngTo) Then
Exit Do
End If
End If
End If
lngOld = vntLinear(lngOld, lngTo)
lngPos = lngPos + 1
Loop
vntLinear(lngOrder, lngTo) _
= vntLinear(lngOld, lngTo)
vntLinear(lngOld, lngTo) = lngOrder
ListSearch = lngPos
End Function
尚、順番を維持するか、追加順にするかは、
以下で決定されます
Private Sub CommandButton2_Click()
MoveItems ListBox2, ListBox1, True
End Sub
の「Sub MoveItems」の第３引数にTureを指定すれば順番を維持
Falseを指定、若しくは、何も指定しない場合、追加順と成ります
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
