☆エクセルのリストボックス間のコピーで、マウス（ドラッグ＆ドロップ）によりコピー先の任意の位置へ挿入できるＶＢＡプログラム。
☆エクセルのリストボックス間のコピーにおいて、マウス（ドラッグ＆ドロップ）により、コピー先リストの任意のポイントへの挿入と、コピー先リスト内でのデータ移動が容易にできるＶＢＡプログラム。 ＊＊＊ サンプルプログラムの使い方 ＊＊＊ 新規でエクセルを開き、ＶＢＡ編集画面で“挿 入(Ｉ)”⇒“ユーザーフォーム(U)”でユーザーフォームを作成し、“ツールボックス”を開いて、作成したユーザーフォームに“リストボックス”をふたつ（向って左に ListBox１、右に ListBox２）貼り付けます。 次に、ユーザーフォームを直接ダブルクリックで開き、下記プログラムリストをコピー＆ペーストで貼り付け、デバックモードで実行します。 ＊通常のコピーは、ListBox１内の目的のデータをダブルクリックするだけで追加コピーされます。 ＊ListBox１からListBox２へのドラッグ＆ドロップでのコピーは、ListBox２内のポインタの前に 挿入されます。 ＊ListBox２へコピーされたデータは、ListBox２内でドラッグ＆ドロップにより自由に移動できます。 ＊変数“ＲｐＦｇ”は、重複チェック用のフラグ（ＯＮ＝１／ＯＦＦ＝０）です。 ＊本プログラムについて何かご不明の点がございましたら､当相談室の掲示板または私書箱まで お気軽にお問い合わせ下さい。 ＊お知らせとお詫び... 下記プログラムにブログの高機能エディタによるとみられる不具合が生じ、そのまま貼り付けて 戴いても動作しないことがありましたが、その後通常のエディタに戻してアップ致しましたので 現在では問題なくお使い戴けます。 この度の不具合につきまして、謹んでお詫び致します。（2007.05.25 13:00）Dim Mx As Integer, Lx As Integer, Dp As Integer, Ip As IntegerDim ClpId As Integer, RpFg As Integer, Sbsz As Integer, MdFg As IntegerDim Temp As StringPrivate Sub UserForm_Initialize()ListBox1.List = _ Array("Excel", "Access", "word", "Outlook", "PowerPoint", "FrontPage", "VisualWebDeveloper", "VisualBasic", "SQL Server") Mx = 0: Lx = 0: ClpId = 0: RpFg = 1: Sbsz = 18: MdFg = 0End SubPrivate Sub ListBox1_AfterUpdate() ClpId = ListBox1.ListIndexEnd SubPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim Fg As Integer ClpId = ListBox1.ListIndex If RpFg = 1 Then Call Rp_Check(ClpId, Fg) End If If Fg = 0 Then ListBox2.SetFocus ListBox2.AddItem ListBox1.List(ClpId) Mx = ListBox2.ListCount Y0 = Mx - 1: Lx = Y0 ListBox2.ListIndex = Y0 End IfEnd SubPrivate Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) MdFg = 1End SubPrivate Sub ListBox1_MouseMove(ByVal Button As _ Integer, ByVal Shift As Integer, ByVal X As _ Single, ByVal Y As Single) Dim MyDataObject1 As DataObject Dim Effect As Integer If Button = 1 And ListBox1.Value > 0 Then Lx = -1 Set MyDataObject1 = New DataObject MyDataObject1.SetText ListBox1.Value Effect = MyDataObject1.StartDrag End IfEnd SubPrivate Sub ListBox2_BeforeDragOver(ByVal Cancel As _ MSForms.ReturnBoolean, ByVal Data As _ MSForms.DataObject, ByVal X As Single, _ ByVal Y As Single, ByVal DragState As Long, _ ByVal Effect As MSForms.ReturnEffect, _ ByVal Shift As Integer) Cancel = True Effect = 1 Y0 = (Y * 1000 / 975) \ 10 If Y0 Lx Then If Y0 >= 0 And Y0 < Mx Then ListBox2.ListIndex = Y0: Lx = Y0 Else If Y0 >= Mx Then Y0 = Mx - 1 ListBox2.ListIndex = Y0: Lx = Y0 End If End IfEnd SubPrivate Sub ListBox2_BeforeDropOrPaste(ByVal _ Cancel As MSForms.ReturnBoolean, _ ByVal Action As Long, ByVal Data As _ MSForms.DataObject, ByVal X As Single, _ ByVal Y As Single, ByVal Effect As _ MSForms.ReturnEffect, ByVal Shift As Integer) Cancel = True Effect = 1 Dim Fg As Integer If RpFg = 1 Then Call Rp_Check(ClpId, Fg) End If If Fg = 0 Then ListBox2.AddItem Data.GetText If ListBox2.ListCount > 1 Then Call Lst2_Ins(ClpId) Else ListBox2.ListIndex = ListBox2.ListCount - 1 End If End If Mx = ListBox2.ListCountEnd SubPrivate Sub ListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) MdFg = 1End SubPrivate Sub ListBox2_MouseMove(ByVal Button As _ Integer, ByVal Shift As Integer, ByVal X As _ Single, ByVal Y As Single) If Button = 1 Then If X >= 0 And X < (ListBox2.Width - Sbsz) And Y >= 0 And Y < ListBox2.Height Then If MdFg = 1 Then Dp = ListBox2.ListIndex MdFg = 2 End If End If End IfEnd SubPrivate Sub ListBox2_MouseUp(ByVal Button As _ Integer, ByVal Shift As Integer, ByVal X As _ Single, ByVal Y As Single) If Dp >= 0 Then Temp = ListBox2.List(Dp) End If If MdFg = 2 Then If X >= 0 And X < (ListBox2.Width - Sbsz) And Y >= 0 And Y < ListBox2.Height Then If Button = 1 And Dp >= 0 Then Ip = ListBox2.ListIndex If Ip Dp Then Call Lst2_Del(Dp) Call Lst2_Ins0(Ip, Temp) End If End If End If End If MdFg = 0End SubSub Rp_Check(ChkId As Integer, Ch As Integer) Dim P As Integer For P = 0 To ListBox2.ListCount - 1 If ListBox2.List(P) = ListBox1.List(ChkId) Then Ch = 1 NextEnd SubSub Lst2_Ins(InsId As Integer) Dim P As Integer If ListBox2.ListIndex < 0 Then ListBox2.ListIndex = ListBox2.ListCount - 1 For P = ListBox2.ListCount - 2 To ListBox2.ListIndex Step -1 ListBox2.List(P + 1) = ListBox2.List(P) Next ListBox2.List(ListBox2.ListIndex) = ListBox1.List(InsId)End SubSub Lst2_Del(DelId As Integer) Dim P As Integer For P = DelId To ListBox2.ListCount - 2 ListBox2.List(P) = ListBox2.List(P + 1) NextEnd SubSub Lst2_Ins0(InsId As Integer, Tmp As String) Dim P As Integer For P = ListBox2.ListCount - 2 To InsId Step -1 ListBox2.List(P + 1) = ListBox2.List(P) Next ListBox2.List(InsId) = TmpEnd Sub 以上、本日“トンちゃん”さんより直接当相談所のメールＢＯＸのほうへご質問戴きましたので、急ぎ回答させて戴きましたが、ご不明な点がございましたら、いつでもお気軽にご質問下さい。
出産・子育て
ファッション
美容・コスメ
健康・ダイエット
生活・インテリア
料理・食べ物
ドリンク・お酒
ペット
趣味・ゲーム
映画・ＴＶ
音楽
読書・コミック
旅行・海外情報
園芸
スポーツ
アウトドア・釣り
車・バイク
パソコン・家電
そのほか
すべてのジャンル
