月日のシートタブを使って，順番に並び替える方法？

質問

こんにちは，よろしくお願いします。

ＶＢＡに関する質問です。

ワークシートのタブに「１２月 １日」とか「 ２月２８日」とか「 ６月１４日」などの名前が付けられています。これらのワークシートを，４月１日から翌年の３月３１日までの順に並べ替えるプログラムを作りたいのですが，どのようにしたらよいか教えてください。

全てのワークシートの名前を取得し，”月”が何文字目に入っているかを検索し，Ｌｅｆｔ関数で月数を切取り，それによって年度を加え，これをCDateで日付関数に変換したりなどして見ました。
For Each Wsht In Worksheets

If InStr(Wsht.Name, "月") = 3 Then

Tuki = CInt(Trim(Left(Wsht.Name, 2)))

If Tuki > 0 And Tuki < 4 Then
Hiduke = "2012年" & Wsht.Name
ElseIf Tuki > 3 And Tuki < 10 Then
Hiduke = "2011年" & Wsht.Name
End If

ElseIf InStr(Wsht.Name, "月") = 4 Then
Hiduke = "2011年" & Wsht.Name
End If

Next

日付関数への変換は抜いていますが，この後，Date型の配列と文字列型の配列を用意し，
Date型の配列にはCDateで変換した値を代入し，文字列型の方には，元々のシートタブの値を代入し，Date型の方で，最小値ををfor～nextで探し出すなどして，文字列型の方を添え字の順になるように並び替えて・・・・もう手一杯です。
さらにこれをWorksheets(" ６月１４日").move before:=**** などというメソッドを使って並び替えなくてはいけないとなると，もう私の力ではオーバーフローです。
すみません。どなたかお助けください。

回答No.2

MARU4812 · ベストアンサー

ついでに
> 日付関数への変換は抜いていますが，
の話ですが、
> If InStr(Wsht.Name, "月") = 3 Then
> ElseIf InStr(Wsht.Name, "月") = 4 Then
なんで上記の条件がいるのか分からないです。
単純に月日を抜き出したいなら、もっと一般化
すればいいとおもいます。

Sub test()
　　Dim Wsht_Name As String

　　Wsht_Name = "１２月 １日"
　　Debug.Print GetTuki(Wsht_Name)
　　Debug.Print GetHiduke(Wsht_Name)

　　Wsht_Name = "　１3月　 134日"
　　Debug.Print GetTuki(Wsht_Name)
　　Debug.Print GetHiduke(Wsht_Name)

　　Wsht_Name = "3月4日"
　　Debug.Print GetTuki(Wsht_Name)
　　Debug.Print GetHiduke(Wsht_Name)

　　Wsht_Name = "3 月4567　 日"
　　Debug.Print GetTuki(Wsht_Name)
　　Debug.Print GetHiduke(Wsht_Name)
End Sub

Function GetTuki(Wsht_Name As String) As Integer
　　GetTuki = CInt(Left(Wsht_Name, InStr(Wsht_Name, "月") - 1))
End Function

Function GetHiduke(Wsht_Name As String) As Integer
　　GetHiduke = CInt(Mid(Wsht_Name, InStr(Wsht_Name, "月") + 1, (InStr(Wsht_Name, "日") - 1) - InStr(Wsht_Name, "月")))
End Function

回答No.5

imogasi

ソートを自作するのが面倒なので、１ワークシートを作業シートにしてそこでソートした。
ーー
下記で平成23年の部分は適当に修正必要。
年月が同年とみなす合
Sub test01()
Dim d1(100), d2(100), d3(100)
Worksheets("Shweet1").Columns("H:H").NumberFormatLocal = "@" '文字列に設定して日付と解釈されなくする
i = 1 'Sheet1における書き出し最初行
For Each sh In Worksheets '全シート数
'MsgBox sh.Name
If sh.Name <> "Sheet1" Then 'Sheet1(作業シート）以外を処理対象にする
d1(i) = sh.Name
d2(i) = DateValue("平成23年" & d1(i))
d3(i) = i
Worksheets("Sheet1").Cells(i, "H") = d1(i)
Worksheets("Sheet1").Cells(i, "I") = d2(i)
Worksheets("Sheet1").Cells(i, "J") = d3(i)
i = i + 1
End If
Next
sn = i - 1 'シート数
'---日付でソート（I列)
With Worksheets("Sheet1")
.Range("H1:J" & sn).Sort Key1:=Range("I1"), Order1:=xlAscending
End With
'---シート並べ替え。
For i = 1 To sn
n = Worksheets("Sheet1").Cells(i, "H") 'シート名
Worksheets(n).Move before:=Worksheets(i)
Next i
End Sub
=====＝＝＝＝＝＝＝＝＝＝＝＝＝
１－３月を来年と解釈する場合。
Sub test02()
Dim d1(100), d2(100), d3(100)
Worksheets("Sheet1").Columns("H:H").NumberFormatLocal = "@"
i = 1
For Each sh In Worksheets '全シート数
'MsgBox sh.Name
If sh.Name <> "Sheet1" Then 'Sheet1(作業シート）以外を処理対象にする
d1(i) = sh.Name
d2(i) = DateValue("平成23年" & d1(i))
d3(i) = i
If Month(d2(i)) >= 1 And Month(d2(i)) <= 3 Then '1-3月は次年と解す
d2(i) = DateSerial(Year(d2(i)) + 1, Month(d2(i)), Day(d2(i)))
End If
Worksheets("Sheet1").Cells(i, "H") = d1(i)
Worksheets("Sheet1").Cells(i, "I") = d2(i)
Worksheets("Sheet1").Cells(i, "J") = d3(i)
i = i + 1
End If
Next
sn = i - 1 'シート数
'---日付でソート（I列)
With Worksheets("Sheet1")
.Range("H1:J" & sn).Sort Key1:=Range("I1"), Order1:=xlAscending
End With
'---シート並べ替え。
For i = 1 To sn
n = Worksheets("Sheet1").Cells(i, "H") 'シート名
Worksheets(n).Move before:=Worksheets(i)
Next i
End Sub

お礼

imogasiさんありがとうございました。
参考にさせていただき，解決いたしました。
作成した，コードを，補足にのせておきましたので，ご覧ください。
本当にありがとうございました。

補足

Sub Sort_Sheet()

Dim Hi As String
Dim Key As String
Dim ShtName() As String
Dim Soeji As Integer
Dim i As Integer
Dim Saidai As Variant
Dim SaidaiSoeji As Integer
Dim HidukeJun() As String
Dim j As Integer

Soeji = 1

ReDim ShtName(1 To 2, 1 To 1)

For Each Wsht In Worksheets

If Right(Wsht.Name, 1) = "日" Then

If GetHiduke(Wsht.Name) < 10 Then
Hi = "0" & CStr(GetHiduke(Wsht.Name))
Else
Hi = CStr(GetHiduke(Wsht.Name))
End If

If GetTuki(Wsht.Name) > 0 And GetTuki(Wsht.Name) < 4 Then
Key = "10" & CStr(GetTuki(Wsht.Name)) & Hi
ElseIf GetTuki(Wsht.Name) > 3 And GetTuki(Wsht.Name) < 10 Then
Key = "0" & CStr(GetTuki(Wsht.Name)) & Hi
ElseIf GetTuki(Wsht.Name) > 9 And GetTuki(Wsht.Name) < 13 Then
Key = CStr(GetTuki(Wsht.Name)) & Hi
End If

ShtName(1, Soeji) = Key
ShtName(2, Soeji) = Wsht.Name
Soeji = Soeji + 1
ReDim Preserve ShtName(1 To 2, 1 To Soeji)

End If

Next

ReDim Preserve ShtName(1 To 2, 1 To Soeji - 1)

ReDim HidukeJun(UBound(ShtName, 2))
Saidai = CInt(ShtName(1, 1))

For j = 1 To Soeji - 1

For i = 1 To Soeji - 1
If CInt(ShtName(1, i)) > Saidai Then
Saidai = CInt(ShtName(1, i))
SaidaiSoeji = i
End If
Next

HidukeJun(j) = ShtName(2, SaidaiSoeji)
ShtName(1, SaidaiSoeji) = "0"
Saidai = 0

Next

For i = 1 To Soeji - 1
If i = 1 Then
Worksheets(HidukeJun(i)).Move before:=Worksheets("master")
Else
Worksheets(HidukeJun(i)).Move before:=Worksheets(HidukeJun(i - 1))
End If
Next

End Sub

Function GetTuki(Wsht_Name As String) As Integer
GetTuki = CInt(Left(Wsht_Name, InStr(Wsht_Name, "月") - 1))
End Function

Function GetHiduke(Wsht_Name As String) As Integer
GetHiduke = CInt(Mid(Wsht_Name, InStr(Wsht_Name, "月") + 1, (InStr(Wsht_Name, "日") - 1) - InStr(Wsht_Name, "月")))
End Function

Function の GetTuki と GetHiduke はMARU4812さんのものをそのまま使わせていただきました。ありがとうございました。

回答No.4

mzon

すこしたのしそうだったのでつくってみました。
参考になれば幸いです。

－－－－－－－－－－－－－－－－－－－－－－－
'　空シートにボタン作って、押された時に動作するようにしてみました。
'　年が1999年になっているのはうるう年なので2月29日があるからです。
' 当年でよい場合は1999の部分を当年2000の部分を翌年にしてみてください。
Private Sub CommandButton1_Click()
On Error Resume Next ' シートがなくてもとまらないようにする
Dim xlsSheet As Worksheet ' シートの存在確認用
Dim dSheetDay As Date ' 処理日付
Dim sSheet(0 To 1) As String ' シートの名前用 0:対象の日、1:前の日

dSheetDay = CDate("1999/04/01") ' 4月１日（初期値）2000年は2/29対応
sSheet(1) = "" ' 初期値空白（先頭へ移動）
Do
sSheet(0) = Format(dSheetDay, "M月D日") ' 日付をシートの名前に変換(1月1日）となる。
'sSheet(0) = StrConv(Format(dSheetDay, "M月D日"), vbWide) ' 漢字の場合はこっち（１月１日）となる
' シートの有無確認
Set xlsSheet = Worksheets(sSheet(0)) ' あればオブジェクトが入る
If Not xlsSheet Is Nothing Then ' シートがある場合
If sSheet(1) <> "" Then ' 先頭以外の場合（）
ThisWorkbook.Sheets(sSheet(0)).Move after:=Sheets(sSheet(1)) ' 対象の日付を前回の後につける
End If
Set xlsSheet = Nothing ' オブジェクト開放（忘れるとメモリリークする）
sSheet(1) = sSheet(0) ' 前の日を記憶（この後に次の日が並ぶ）
End If
dSheetDay = DateAdd("d", 1, dSheetDay) ' 1日移動
If CLng(Format(dSheetDay, "YYYYMM")) >= 200004 Then ' 次の年（2000年04）になったら
Exit Do ' ループおしまい
End If
Loop
End Sub

お礼

mzonさんありがとうございました。
参考にさせていただき，解決いたしました。
作成した，コードを，回答（５）さんの補足にのせておきましたので，ご覧ください。
本当にありがとうございました。

回答No.3

mu2011

一案です。
別シートに４月２日から３月３１日の文字列リストを作り、その行順に従って並び替える方法は如何でしょうか。

以下のコードを標準モジュールに貼り付けて実行してみて下さい。
Sub sample()
On Error Resume Next　'該当日付のシートがない場合の対応
Sheets("４月１日").Select
Set st = sheets("別シート")
For i = 1 To st.Cells(Rows.Count, 1).End(xlUp).Row
Sheets(st.Cells(i, 1).Value).Move After:=ActiveSheet
Next
End Sub

お礼

mu2011さんありがとうございました。
参考にさせていただき，解決いたしました。
作成した，コードを，回答（５）さんの補足にのせておきましたので，ご覧ください。
本当にありがとうございました。

回答No.1

MARU4812

日付に変換するのが難しいなら。。。
１２月 １日 --> 1201
６月１４日 --> 614(0614)
年度区切りなので1月から3月は
２月２８日 --> 10228
の数値に変換したものをキーにして、並び替えれば
簡単なんじゃないかなぁ。

個別の配列を用意するより。。。
作業用シートを追加して、上記キーとシート名を
2列に並べておいて Range の Sort でセットで並び
替えてしまえば、あとは上から順番のシート順にして
いくだけ？

お礼

MARU4812さんありがとうございました。
参考にさせていただき，解決いたしました。
作成した，コードを，回答（５）さんの補足にのせておきましたので，ご覧ください。
本当にありがとうございました。