Excel 並べ替え フォームから実行 VBA

質問

フォームに、重複しないデータを入力し、
それを並び替えしたいと思っています。

Excel上に図の左側ようなデータを入力してあります。

名前　科目　点数
木村　英語　50
小林　英語　40
瀬戸　英語　5
岡村　英語　70
木村　国語　80
小林　国語　20
瀬戸　国語　40
岡村　国語　10
・
・
・

重複しないデータをフォームのリストボックス上に書き出します。
例

木村　　　英語
小林　　　国語
瀬戸　　　数学
岡村　　　社会
　　　　　　音楽
　　　　　　理科
・
・
・

リストボックスの行を選択し、
上や下などを押したら、Excel上のデータが右図のように
並び替えられて欲しいのです。

何か良い方法はありますか？

説明不足の点があるとはおもいますが、
回答よろしくお願い致します。

回答No.1

cj_mover · ベストアンサー

こんにちは。

条件
　・Excel2003（最近のご質問を検索したところ、Excel2003らしいので）
　　　バージョン互換、未検証。
　　　Excel2007 以降のバージョンでは、
　　　.Sort メソッドではなく、.Sort オブジェクトが推奨されています。
　・シート名＝"Sheet1"　　'　　■
　・セル範囲参照＝"A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row　　'　　■
　・コントロールのオグジェクト名
　　　添付画像、左から
　　　ListBox1　　'　　■　　 '　　■■
　　　SpinButton1　　 '　　■■
　　　ListBox2　　'　　■　　 '　　■■
　　　SpinButton2　　 '　　■■
　・コマンドボタンを追加
　　　オブジェクト名＝CommandButton1　　 '　　■■
※SpinUp、SpinDown、に連動してListBoxをソート、
　CommandButton1_Click、のタイミングでListBoxの順にシートデータをソート。
　SpinButtonから直接シートデータをソートするのは（出来るには出来るけれど）
　煩雑過ぎてトラブルの元になるという判断です。

技術的なポイントとしては
　Scripting.Dictionary
　Application.AddCustomList
　　　　　　.CustomListCount
　　　　　　.DeleteCustomList
　.Sort Kメソッドの　名前付き引数 OrderCustom
等です。
独自に理解を深めるようにしてください。

解説が必要な部分があるということなら要望あればお応えするかも知れませんが、
使用環境や要求仕様に纏わる"オカワリ"については、
このスレの補足欄に書かれたとしても
（適切な補足がそんなに簡単にできるものではないでしょうから）
お応えできないものとお考えの上、先ずは自力応用に努めて下さい。

テストの際の注意事項。
　下記サンプルを、モジュール内に他に記述がない状態で試す方が
　紛れがなくて無難です。
　Excel2003 環境で、動作確認、検証済です。
運用に合わせて要指定
　値を指定　　'　　■
　オブジェクト名を指定　　 '　　■■
参照設定はオプションです。　　' ▲

' ' ＝＝＝＝＝＝＝＝＝＝＝　UserForm　モジュール　＝＝＝＝＝＝＝＝＝＝
' ' 参照設定　：　Microsoft Scripting Runtime　　' ▲
' '　ーーーー　モジュール（先頭）宣言部　ーーーーー
' '　ーーーーーーーーーーーーーーーーーーーーーーー
Option Explicit　　'　　8351979

Private Const シート名 As String = "Sheet1"　　'　　■
Private セル範囲参照 As String　　'　　タイトル行除く
Private Const リスト1 As String = "ListBox1"　　 '　　■
Private Const リスト2 As String = "ListBox2"　　 '　　■

Private Enum MySpinDir
　　mySpinUp = -1
　　mySpinDown = 1
End Enum

Private ListBoxes(1 To 2) As MSForms.ListBox
Private arrCnList(1 To 2) As Long
' '　ーーーーーーーーーーーーーーーーーーーーーーー

Private Sub UserForm_Initialize()

　　Dim oDict As Object　　'　　Dim oDict As Scripting.Dictionary　　' ▲
　　Dim mtxSrc()
　　Dim i As Long

　　With Sheets(シート名)
　　　　セル範囲参照 = "A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row　 '　　■タイトル行除く
　　　　mtxSrc() = .Range(セル範囲参照).Resize(, 2).Value
　　End With

　　Set oDict = CreateObject("Scripting.Dictionary")　　'　　Set oDict = New Scripting.Dictionary　　' ▲

　　For i = 1 To UBound(mtxSrc)
　　　　oDict(mtxSrc(i, 1)) = Empty
　　Next i
　　arrCnList(1) = oDict.Count
　　Set ListBoxes(1) = Me.Controls(リスト1)
　　ListBoxes(1).List = oDict.Keys
　　ListBoxes(1).ListIndex = 0

　　oDict.RemoveAll
　　For i = 1 To UBound(mtxSrc)
　　　　oDict(mtxSrc(i, 2)) = Empty
　　Next i
　　arrCnList(2) = oDict.Count
　　Set ListBoxes(2) = Me.Controls(リスト2)
　　ListBoxes(2).List = oDict.Keys
　　ListBoxes(2).ListIndex = 0

　　Set oDict = Nothing: Erase mtxSrc()
End Sub

Private Sub SpinSort(ByVal nBoxIndex As Long, _
　　　　　　　　　　ByVal SpinDir As MySpinDir)
　　Dim sBuf
　　Dim nListIndex As Long
　　With ListBoxes(nBoxIndex)
　　　　nListIndex = .ListIndex
　　　　Select Case SpinDir
　　　　Case mySpinUp
　　　　　　If nListIndex = 0 Then Exit Sub
　　　　Case mySpinDown
　　　　　　If nListIndex >= arrCnList(nBoxIndex) - 1 Then Exit Sub
　　　　End Select
　　　　sBuf = .Value
　　　　.List(nListIndex) = .List(nListIndex + SpinDir)
　　　　.List(nListIndex + SpinDir) = sBuf
　　　　.ListIndex = nListIndex + SpinDir
　　End With

End Sub

Private Sub SpinButton1_SpinUp()　　 '　　■■
　　SpinSort 1, mySpinUp
End Sub

Private Sub SpinButton1_SpinDown()　　 '　　■■
　　SpinSort 1, mySpinDown
End Sub

Private Sub SpinButton2_SpinUp()　　 '　　■■
　　SpinSort 2, mySpinUp
End Sub

Private Sub SpinButton2_SpinDown()　　 '　　■■
　　SpinSort 2, mySpinDown
End Sub

Private Sub CommandButton1_Click()　　 '　　■■
　　Dim cnCustomList As Long

　　With Application

　　　　.AddCustomList ListBoxes(1).List
　　　　.AddCustomList ListBoxes(2).List
　　　　cnCustomList = .CustomListCount

　　　　With Sheets(シート名).Range(セル範囲参照)

　　　　　　.Sort Key1:=.Cells(1), Order1:=xlAscending, _
　　　　　　　　Header:=xlNo, OrderCustom:=cnCustomList, _
　　　　　　　　MatchCase:=True, Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlStroke, DataOption1:=xlSortNormal

　　　　　　.Sort Key1:=.Cells(2), Order1:=xlAscending, _
　　　　　　　　Header:=xlNo, OrderCustom:=cnCustomList + 1, _
　　　　　　　　MatchCase:=True, Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlStroke, DataOption1:=xlSortNormal

　　　　End With

　　　　.DeleteCustomList (cnCustomList)
　　　　.DeleteCustomList (cnCustomList - 1)
　　End With
End Sub

お礼

回答ありがとうございます。
ただいまとても忙しく、確認できない状況ですが、
時間を作って早めに確認しようと思います！
もっとVBAについての知識を深めたいと思います。

回答No.2

WindFaller

このままですと、レスが付かないと思います。
まず、ExcelのVersion はいくつですか？

次に、リストボックスで、選択して、ダウンアロー・ボタンを押したら、それが連動して、リストの中の名前が一斉に下に行くということですか？任意の並べ替えということで、Excelの降順・昇順などとは違うようです。

木村・小林・瀬戸・岡村　→　木村・瀬戸・小林・岡村

一体、何のためなのかという疑問も感じます。それも、リストボックスからの操作というので、余計に複雑にしています。どこまで出来ているか分かりませんが、どうやら、ある程度の外形までは出来ているようです。

もし私の書いた想像が正しいなら、たぶん、時間を取って作ってあげるという人もいるかもしれませんが、そういうコードは、レスをつけたにも関わらず、残念ながら、私には、まったく自信ないですね。

補足

Excelは2003を使用しています。
リストボックスで、選択して、
ダウンアロー・ボタンを押したら、
それが連動して、リストの中の名前が一斉に下に行くということですか？
→その通りです。
　リストの中の名前と同じExcel上の名前などの位置が
　上、または下に行きます