Excel VBA質問箱 IV

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

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


1434 / 13645 ツリー ←次へ | 前へ→

【74504】リストボックスからリストボックスへ重複なしで移動させたいです。 ぺろ 13/7/5(金) 16:30 質問[未読]
【74507】Re:リストボックスからリストボックスへ重... UO3 13/7/6(土) 3:29 発言[未読]
【74508】Re:リストボックスからリストボックスへ重... kanabun 13/7/6(土) 10:16 発言[未読]
【74509】Re:リストボックスからリストボックスへ重... ぺろ 13/7/6(土) 11:02 発言[未読]
【74510】Re:リストボックスからリストボックスへ重... kanabun 13/7/6(土) 11:07 発言[未読]
【74511】Re:リストボックスからリストボックスへ重... ぺろ 13/7/6(土) 11:19 お礼[未読]
【74512】Re:リストボックスからリストボックスへ重... ichinose 13/7/7(日) 20:14 発言[未読]
【74513】Re:リストボックスからリストボックスへ重... ぺろ 13/7/8(月) 8:25 お礼[未読]

【74504】リストボックスからリストボックスへ重複...
質問  ぺろ  - 13/7/5(金) 16:30 -

引用なし
パスワード
   こんにちは
お助けください。

listboxを2つ作成し、
listbox1からlistbox2へドラッグして値を代入する作業を
moug(モーグ)のサイトとこちらを参考にして作成しています。
(以下のマクロです)

それで、listbox1からlistbox2に移動する際に、
既にlistbox2に移動させようとしているものが存在している場合、
移動させないようにしたいのです。

現状では、同じ項目をドラッグした場合、listbox2に同じものが
いくつも並んでしまいます。


Private Sub UserForm_Initialize()
Application.ScreenUpdating = False

  Dim LastRow As Long
  Dim mydata As Variant

  
  With Sheets("マスタ1")
     LastRow = .Range("A1").CurrentRegion.Rows.Count
     mydata = .Range(.Cells(2, 1), .Cells(LastRow, 2)).Value
  End With
  
  With ListBox1
    .List = mydata
    .ColumnCount = 2
    .ColumnWidths = "80;229"
  End With
  
  With ListBox2
    .ColumnCount = 2
    .ColumnWidths = "80;229"
  End With
  
End Sub


'リストボックス1のマウス移動時(ドラッグ開始)
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

'マウス左ボタンのドラッグ時に対応
If Button <> 1 Then Exit Sub
'データオブジェクトに現在の選択地を格納
Dim i As Long
With ListBox1
  ReDim ss(.ColumnCount - 1)
  For i = 0 To .ColumnCount - 1
  ss(i) = .List(.ListIndex, i)
    
Next i
End With

With New DataObject
   .SetText Join(ss, vbTab)
   .StartDrag
End With
End Sub

'リストボックス2へのドラッグ(In)
Private Sub ListBox2_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)
'二番目のリストボックスにマウスが入った時のイベント
'Cancel=TrueでDrag&Drop継続
Cancel = True

End Sub
'リストボックス2へのドロップ
Private Sub ListBox2_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)

Dim ss
Dim i, j As Long
Dim NewIndex As Long

'ドラッグ時のみドラッグされたデータをリスト項目に追加
If Action = fmActionDragDrop Then
  ss = Split(Data.GetText(), vbTab)
 
With ListBox2

.AddItem ss(0), NewIndex

For i = 1 To UBound(ss)
.List(NewIndex, i) = ss(i)
Next i

End If
End With
End If

Data.Clear 'DataObjectのデータクリア


End Sub

【74507】Re:リストボックスからリストボックスへ...
発言  UO3  - 13/7/6(土) 3:29 -

引用なし
パスワード
   ▼ぺろ さん:

こんばんは

回答の前に。
コードは動いているものをそのままコピペしてアップされた方がいいですよ。
アップされたコードをそのまま貼り付けてコンパイルしますとコンパイルエラーになりますよね。
ListBox2_BeforeDropOrPaste 内の End If が1つ余分のようですよ。
それと、シート名に限らずエクセル内では半角カナは機種依存ですので使わない方がよろしいかと。

さて、重複の回避ですけど、ざっと眺めたコードの流れで言えば、ドロップ時にListBox2内にコードが
存在するかどうかで、処理分岐されるのが簡単かなと思います。

・ListBox2のListが生成されていない場合は、実行
・ListBox2のListが生成されていれば、その1列目をWorkSheetFunction.Indexあたりで取り出し
 その1列の配列に対して、ドロップしようとしているデータの1列目の値があるかどうかを
 Application.Match あたりで判定。なければ実行

こんなことではいかがでしょう。

【74508】Re:リストボックスからリストボックスへ...
発言  kanabun  - 13/7/6(土) 10:16 -

引用なし
パスワード
   ▼ぺろ さん:

よこから失礼します

>listbox1からlistbox2へドラッグして値を代入する作業を
>moug(モーグ)のサイトとこちらを参考にして作成しています。
>
>それで、listbox1からlistbox2に移動する際に、
>既にlistbox2に移動させようとしているものが存在している場合、
>移動させないようにしたいのです。

それぞれのリストを Dictionaryオブジェクトに覚えさせておく方法
(毎回 重複してないか調べない方法)です。

'★Microsoft Scripting Runtime への参照設定
Private dic1 As Scripting.Dictionary
Private dic2 As Scripting.Dictionary
Private movRow As Long  '移動行
Private movKey As String '移動キー項目

Private Sub UserForm_Initialize()
 Dim r As Excel.Range
 Dim i As Long
 
 Set dic1 = New Dictionary
 Set dic2 = New Dictionary

  Set r = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 2)
  Set r = Intersect(r, r.Offset(1))
  
  With ListBox1
    .List = r.Value
    .ColumnCount = 2
    .ColumnWidths = "80;229"
    For i = 0 To .ListCount - 1
      'Dictionaryの KeyにListの1列目を 全列をアイテムに記録
      dic1(.List(i, 0)) = WorksheetFunction.Index(r.Rows(i + 1), 0#)
    Next
  End With

  With ListBox2
    .ColumnCount = 2
    .ColumnWidths = "80;229"
  End With

End Sub


'リストボックス1のマウス移動時(ドラッグ開始)
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
 ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

 'マウス左ボタンのドラッグ時に対応
 If Button <> 1 Then Exit Sub
 'データオブジェクトに現在の選択値を格納
 Dim i As Long
 With ListBox1
   movRow = .ListIndex
   movKey = .List(movRow, 0)
 End With
 
 With New DataObject
   .StartDrag
 End With
End Sub

'二番目のリストボックスにマウスが入った時のイベント
Private Sub ListBox2_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)
  
  'Cancel=TrueでDrag&Drop継続
  Cancel = True

End Sub

'リストボックス2へのドロップ
Private Sub ListBox2_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)

 Dim ss
 Dim i As Long, j As Long '◆
 
 'ドラッグ時のみドラッグされたデータをリスト項目に追加
 If Action = fmActionDragDrop Then
   If dic2.Exists(movKey) Then Exit Sub
   
   ss = dic1(movKey)
   dic2(movKey) = ss
   With ListBox2
     .AddItem ss(1, 1)
     .List(.ListCount - 1, 1) = ss(1, 2)
   End With
   '-------------------------- 以下はコピーのときは不要
   'ListBox1と dic1 から削除
   'ListBox1.RemoveItem movRow
   'dic1.Remove movKey
 End If

End Sub

【74509】Re:リストボックスからリストボックスへ...
発言  ぺろ  - 13/7/6(土) 11:02 -

引用なし
パスワード
   ▼kanabun さん:

kanabun さん!!
返信ありがとうございます!!

見事に動き、感動し興奮状態です!

ひとつ質問なのですが、
microsoft scripting runtimeを設定されていますが、
これはこのプログラムを他の人のパソコンで使った場合、
やはり、microsoft scripting runtime にチェックをいれないと
作動しないでしょうか。
(恥ずかしながらここにチェックをいれたことが初めてだったので(><)

業務上、パソコン初心者のような人にも使ってもらいたいと思っており、
エクセルの”開発”を知らない人がほとんどなのです...


もしmicrosoft scripting runtime にチェックを入れなくても
作動するようになればとてもうれしいのですが、ご教授いただけないでしょうか。

よろしくお願いいたします。

【74510】Re:リストボックスからリストボックスへ...
発言  kanabun  - 13/7/6(土) 11:07 -

引用なし
パスワード
   ▼ぺろ さん:

>microsoft scripting runtime にチェックを入れなくても
>作動するようになれば

Private dic1 As Object '◆
Private dic2 As Object '◆
Private movRow As Long  '移動行
Private movKey As String '移動キー項目

Private Sub UserForm_Initialize()
 Dim r As Excel.Range
 Dim i As Long
 
 Set dic1 = CreateObject("Scripting.Dictionary") '◆
 Set dic2 = CreateObject("Scripting.Dictionary") '◆

(以下省略)

こうですね?

【74511】Re:リストボックスからリストボックスへ...
お礼  ぺろ  - 13/7/6(土) 11:19 -

引用なし
パスワード
   kanabunさん

こんなに簡単なことだったのですね!!!
素晴らしいです!
ありがとうございました!!
今後dictionary多用してみます!

UO3さん
kanabunさん
返信ありがとうございました。

【74512】Re:リストボックスからリストボックスへ...
発言  ichinose  - 13/7/7(日) 20:14 -

引用なし
パスワード
     こんばんは。

解決後ですが、Listbox2登録メンバーで重複をチェックする方法です。


ListBox2の BeforeDropOrPasteイベント以外は、 ぺろさんの投稿コードを
そのまま生かすこととします。

よって、
BeforeDropOrPasteイベントプロシジャーだけ。


Private Sub ListBox2_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)
  Dim ss
  Dim i As Long, j As Long
  Dim NewIndex As Long
  Dim marray As Variant
  Dim ret As Long
'ドラッグ時のみドラッグされたデータをリスト項目に追加
  If Action = fmActionDragDrop Then
    ss = Split(Data.GetText(), vbTab)
    With ListBox2
     ret = 1
     If .ListCount > 0 Then
       If IsError(Application.VLookup(ss(0), .List, 1, False)) Then
        .AddItem ss(0), 0
        For i = 1 To UBound(ss)
         .List(NewIndex, i) = ss(i)
        Next i
       End If
     Else
       ReDim marray(0 To 0, 0 To UBound(ss))
       For i = 0 To UBound(ss)
        marray(0, i) = ss(i)
       Next i
       .List() = marray
       Erase marray
     End If
    End With
  End If
  Data.Clear 'DataObjectのデータクリア
End Sub


【74513】Re:リストボックスからリストボックスへ...
お礼  ぺろ  - 13/7/8(月) 8:25 -

引用なし
パスワード
   ichinoseさん

こんにちは
既存のコードを活かしたまま利用できるコードをありがとうございます!
どちらも利用してみて勉強していこうと思います!

本当にありがとうございました!

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