マクロで並べ替えを複数のシートそれぞれに行う方法を教えてください

レストランの予約表のメニューと注文数をマクロで並べ替えするため、
エクセル上ではユーザー定義の並べ替えを365日分行っておりました。

マクロ初心者のため、自動記録を使って以下のようなプログラムが書かれたのですが、
１シートに１日分の予約があり、プログラムの中にシート名の記載があります。
このままだと365日分のプログラムを書かなくてならないことになりますが、
それぞれのシートにマクロ実行ボタンを作り、
そのシートごとに並べ替えかできるためには、
この方法しかないのでしょうか？

以下がプログラムの内容です。

Sub hd()

' オーダー並べ替え

Range("E17:Q36").Select
ActiveWorkbook.Worksheets("1月1日").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("1月1日").Sort.SortFields.Add Key:=Range("P17:P36"), _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"ハンバーグ,エビフライ,グラタン,オムライス,お子様ランチ,ランチセット", DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("1月1日").Sort.SortFields.Add Key:=Range("Q17:Q36"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("1月1日").Sort
.SetRange Range("E17:Q36")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/07/07 07:20

こんにちは。

>１シートに１日分の予約があり、プログラムの中にシート名の記載があります。

私も、昔は、1シートにひとつの処理するマクロを置いていたのですが、ファイルとして大きくなるだけでなく、マクロの修正の時に、本当に大変になってしまいます。ボタンが、ActiveX コントロールというのもいけなかったでした。それで作りなおしました。

マクロのコードのシート名は、ActiveSheet で良いです。
また、データの多い少ないは、大きさを自動で換えられます。
左端の一番上だけは決めてください。以下の場合は、E17 になっています。
ただし、ひとつのブックの中に、シートの365枚は作らないほうがよいです。管理が面倒になってしまいます。

次に、マクロの置く場所は標準モジュールです。
それに、「フォームのボタン」を[SortMacro]で、登録します。

今回は、カスタムオーダーリストを登録するマクロを作りました。以下では、Sheet3のA2から、下に向かって、リストが書かれています。しかし、ソートマクロといっしょに行ったら、ブックがハングしましたので、分離しました。そして、ユーザー登録したリストの削除するマクロも作りました。

実際は、リストは、同じブック内のどこでもよいし、一旦、リストを登録したら、シートに書き込みしたものは、削除しても残ります。

num = Application.CustomListCount　
CustomOrder:=num　コードの中で、num というのは、最後にカスタムリストを登録した番号のことです。

さて、同じブック内なら、シート全体をコピーして使っても構いません。ボタンの機能も一緒に着いていきます。

なお、マクロを移す時は、シートのコピー－>新規ブックでよいのですが、マクロのコード自体は、新しいブックの標準モジュールに貼り付けるか、エクスポート・インポートしてあげればよいです。その時に、フォーム・ボタンの中身のマクロの登録も、新しいブックに登録しなおしてください。マクロで、そういうことも可能ですが、ちょっと大げさですね。

'//
'Option Explicit
Sub SortMacro()
　Dim OrderList As Variant
　Dim LastCell As Range
　Dim Rng As Range
　Dim num As Integer
　num = Application.CustomListCount
　On Error GoTo ErrHandler
　With ActiveSheet
　　With .Range("E17").CurrentRegion
　　　Set LastCell = .Cells(.Cells.Count)
　　End With
　　Set Rng = .Range("E17", LastCell)
　　 .Sort.SortFields.Clear
　　.Sort.SortFields.Add _
　　Key:=Rng.Columns(12), _
　　SortOn:=xlSortOnValues, _
　　Order:=xlAscending, _
　　CustomOrder:=num, _
　　DataOption:=xlSortNormal
　　
　　.Sort.SortFields.Add Key:=Rng.Columns(13), _
　　SortOn:=xlSortOnValues, _
　　Order:=xlDescending, _
　　DataOption:=xlSortTextAsNumbers
　　
　　End With
　　With ActiveSheet.Sort
　　.SetRange Rng
　　.Header = xlYes
　　.MatchCase = False
　　.Orientation = xlTopToBottom
　　.SortMethod = xlPinYin
　　.Apply
　End With
ErrHandler:
　 If Err.Number <> 0 Then
　　 MsgBox Err.Number & ": " & Err.Description
　 End If
End Sub
Sub ResisterOrderList()
'カスタムリストの登録
　Dim num As Integer
　Dim myList As Variant
　Dim buf As String
　On Error Resume Next
　With Worksheets("Sheet3")
　　'（場所は任意)ここでは、Sheet3のA2から一列
　　Application.AddCustomList .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　End With
　If Err() <> 0 Then
　　num = Application.CustomListCount
　　myList = Application.GetCustomListContents(num)
　　buf = Mid(Join(myList, ","), 1, 15)
　　MsgBox buf & "...." & vbCrLf & _
　　"すでに登録している可能性があります。", vbExclamation
　End If
　On Error GoTo 0

End Sub
Sub DeleteCustomOrderList()
'カスタムリストの削除
Dim num As Integer
Dim myList As Variant
Dim buf As String
　 With Application
　 On Error Resume Next
　　num = .CustomListCount
　　myList = .GetCustomListContents(num)
　　buf = Mid(Join(myList, ","), 1, 15)
　　If MsgBox(buf & "...." & vbCrLf & _
　　"このリストを削除してよろしいですか？", vbOKCancel) = vbOK Then
　　　.DeleteCustomList num
　　End If
　 On Error GoTo 0
　 End With
End Sub

'///

この回答へのお礼

とても細かくご指導いただきまして、感謝の言葉が見つかりません！！！
まだまだ勉強中の身なので、ひとつづつ作っていきたいと思いますが、きちんと理解するまでには時間がかかりそうですので、
まずは取り急ぎお礼を申し上げます。

お礼日時：2015/07/08 02:24