Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


51600 / 76732 ←次へ | 前へ→

【29995】Re:リストボックスへの追加について
回答  Hirofumi  - 05/10/17(月) 20:53 -

引用なし
パスワード
   >できないのが、左側で選択したデータを右側リストの選択されているリスト行に
>追加するやりかたです。

これは、右のListBoxで選択された行を、左のListBoxに戻すということですか?

例えば、WorkSheets("Sheet1")に以下の様なデータが有るとします
  A   B
1 商品A 100円
2 出張費 500円
3 商品B 200円
4 商品C 300円
5 ・・

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に2列表示の場合、以下を活かす
'    .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に2列表示の場合、以下を活かす
'    .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に2列表示の場合、此方を使用
'    vntItems = .Resize(lngRows, 2).Value
    'ListBoxに1列表示の場合、此方を使用
    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に2列表示の場合、以下を活かす
'          lstTo.List(lstTo.ListCount - 1, 1) = .List(i, 1)
        Else
          lstTo.AddItem .List(i, 0), lngPos
          'ListBoxに2列表示の場合、以下を活かす
'          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」の第3引数にTureを指定すれば順番を維持
Falseを指定、若しくは、何も指定しない場合、追加順と成ります
0 hits

【29986】リストボックスへの追加について hatena 05/10/17(月) 19:24 質問
【29987】Re:リストボックスへの追加について MokoMoko 05/10/17(月) 19:31 発言
【29992】Re:リストボックスへの追加について ichinose 05/10/17(月) 20:09 発言
【29995】Re:リストボックスへの追加について Hirofumi 05/10/17(月) 20:53 回答
【30034】Re:リストボックスへの追加について hatena 05/10/18(火) 17:27 お礼

51600 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free