VBA 特定の範囲のシートを並べ替えをして、処理後

質問

VBA 特定の範囲のシートを並べ替えをして、処理後にマクロ実行前のシートを表示させたい。

EXCEL2013を使用しています。
現在、以下のような構文を使用して、保存時に実行しています。
処理は、シート名を書き換えてシート保護をかけて先頭から9番目のシートのA1へ戻るようにしています。
これを、次のような処理にしたいと考えています。
１．シート名を書き換え
２．シート保護
３．先頭から9番目のシートから、31番目のシートをシート名でソート
４．マクロ実行前に作業していたシートへ戻る

ちなみに、書き換えたシート名が、"１．○○○" や、"２．△△△"などになっているのですが、"."より前の値で並び替えられると便利になります。
また、デフォルトのシート名のままのものと、書き換えられたものがあり、書き換えられたものにだけ"."つきのシート名になります。

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

*******************************
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

'画面のちらつき防止
Application.ScreenUpdating = False

'シート名更新
For i = 1 To Sheets.Count
Sheets(i).Select
Sheets(i).Name = Range("A1").Value
Next i

'全シート保護
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Protect Password:="aoken", _
DrawingObjects:=False, _
Contents:=True, _
AllowInsertingRows:=True, _
AllowDeletingRows:=True, _
Scenarios:=True, AllowFormattingCells:=True

Next ws

Application.Goto Sheets(9).Range("A1"), True

End Sub
*******************************

回答No.2

kagakusuki · ベストアンサー

一例です。
　但し、

>書き換えたシート名が、"１．○○○" や、"２．△△△"などになっているのですが、"."より前の値で並び替えられる

は完全には実現しておらず、例えば "１0．○○○" と "２．△△△" があった場合などには、先頭の文字は "1"よりも"2"の方が大きいため、 "１0．○○○" よりも "２．△△△" の方が後になります。

Sub Macro()

Dim temp As Variant, i As Integer, n As Integer, j As Integer, _
SN() As String, UnavailableName As String, _
myActiveSheet As Worksheet, myActiveCell As Range

Set myActiveSheet = ActiveSheet
Set myActiveCell = ActiveCell
n = Sheets.Count
ReDim SN(1 To n)

For i = 1 To n
SN(i) = Sheets(i).Name
Next i

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

For i = 1 To n
With Sheets(i)
temp = .Range("A1").Value
On Error Resume Next
.Name = temp
On Error GoTo 0
If temp <> "" And Not .Name = temp Then
UnavailableName = UnavailableName & vbCrLf & .Name & " → " & temp
.Tab.Color = RGB(255, 0, 0)
End If
End With
Next i
If UnavailableName <> "" Then
For i = 1 To n
Sheets(i).Name = SN(i)
Next i
MsgBox "各シートのA1セルに入力されている文字列の中に、" _
& "シート名として使用出来ない文字が含まれている文字列か、" _
& "或いは既に他のシートで使用済みのシート名と同名の文字列" _
& "のものがあるため、シート名の変更が出来ません。" & vbCrLf _
& "シート名の変更が出来ないのは下記の変更箇所です。" & vbCrLf _
& UnavailableName & vbCrLf & vbCrLf _
& "マクロの実行を一旦中止しますので、上記のシートのA1セルに" _
& "入力されている値をシート名として使用可能なものに訂正してから、" _
& "本マクロによる処理をやり直して下さい。" _
, vbInformation, "シート名不適切"
GoTo labelE
End If
For i = 9 To n
For j = n To i Step -1
If Sheets(i).Name > Sheets(j).Name Then
Sheets(j).Move Before:=Sheets(i)
End If
Next j
Next i

labelE:
myActiveSheet.Activate
myActiveCell.Activate
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

補足

早速の解答ありがとうございます。

やはりなかなか難しいですね。
ご指摘いただいた部分が非常にネックになっています。
実は、"１．○○○" や、"２．△△△"の一ケタの数字は、2バイトの全角なのです。"10.□□□"は、1バイトの半角数字なのです。
これを、順番にするのは難しいでしょうか？

回答No.3

kagakusuki

>ご指摘いただいた部分が非常にネックになっています。
>実は、"１．○○○" や、"２．△△△"の一ケタの数字は、2バイトの全角なのです。"10.□□□"は、1バイトの半角数字なのです。
>これを、順番にするのは難しいでしょうか？

　改良版です。
　「.」付きの数字がシート名の先頭にある場合には、「.」よりも前の部分にある数字の部分通りに並べ替え、「.」付きの数字が先頭には無いシート名を持つシートは、文字コード順に並べ替えた上で右端の方へ移動する様にしております。
　「.」よりも前の部分にある数字が全角なのか半角なのかには影響されずに並べ替えられる様にしました。
　尚、「.」付きの数字が先頭には無いシート名の場合は、全角文字の「Ａ」よりも半角文字の「Z」の方が左側になります。
　同様に、小文字の「a」よりも大文字の「Z」の方が左側に来ます。(そのため、シート名が例えば「Sheet999」と「a」では、「Sheet999」の方が左側になります)
　半角小文字の「z」と全角大文字の「Ａ」では、半角小文字の「z」の方が左側になります。

Sub QNo9099594_VBA_特定の範囲のシートを並べ替え()

Dim n As Integer, i As Integer, j As Integer, k As Integer, _
mySheetName(1) As String, SN() As String, UnavailableName As String, _
myActiveSheet As Worksheet, myActiveCell As Range, temp As Variant

'現在の選択位置を記録
Set myActiveSheet = ActiveSheet
Set myActiveCell = ActiveCell

'処理前のシート名のバックアップ
n = Sheets.Count
ReDim SN(1 To n)
For i = 1 To n
SN(i) = Sheets(i).Name
Next i

'必要のない処理の停止
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

'シート名の変更
For i = 1 To n
With Sheets(i)
temp = .Range("A1").Value
On Error Resume Next
.Name = temp
On Error GoTo 0
If temp <> "" And Not .Name = temp Then
UnavailableName = UnavailableName & vbCrLf & .Name & " → " & temp
.Tab.Color = RGB(255, 0, 0)
End If
End With
Next i

'指定されているシート名の中に不適切な名称があった場合には、
'シート名を元に戻して、マクロを終了する
If UnavailableName <> "" Then
For i = 1 To n
Sheets(i).Name = SN(i)
Next i
MsgBox "各シートのA1セルに入力されている文字列の中に、" _
& "シート名として使用出来ない文字が含まれている文字列か、" _
& "或いは既に他のシートで使用済みのシート名と同名の文字列" _
& "のものがあるため、シート名の変更が出来ません。" & vbCrLf _
& "シート名の変更が出来ないのは下記の変更箇所です。" & vbCrLf _
& UnavailableName & vbCrLf & vbCrLf _
& "マクロの実行を一旦中止しますので、上記のシートのA1セルに" _
& "入力されている値をシート名として使用可能なものに訂正してから、" _
& "本マクロによる処理をやり直して下さい。" _
, vbInformation, "シート名不適切"
GoTo labelE
End If

'シートの並べ替え
For i = 9 To n
For j = i + 1 To n
mySheetName(0) = Sheets(i).Name
mySheetName(1) = Sheets(j).Name
For k = 0 To 1
If IsNumeric(Left(mySheetName(k), InStr(StrConv(mySheetName(k), vbNarrow) & ".", "."))) _
Then mySheetName(k) = Right(String(60, 0) & StrConv(mySheetName(k), vbNarrow), 60)
Next k
If mySheetName(0) > mySheetName(1) Then Sheets(j).Move Before:=Sheets(i)
Next j
Next i

'全シート保護
For i = 1 To n
Sheets(i).Protect Password:="aoken", _
DrawingObjects:=False, _
Contents:=True, _
AllowInsertingRows:=True, _
AllowDeletingRows:=True, _
Scenarios:=True, AllowFormattingCells:=True
Next i

labelE:
'元の選択位置に戻る
myActiveSheet.Activate
myActiveCell.Activate

'自動再計算とモニター更新の再開
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub
'シートの並べ替え
For i = 9 To n
For j = i + 1 To n
mySheetName(0) = Sheets(i).Name
mySheetName(1) = Sheets(j).Name
For k = 0 To 1
If IsNumeric(Left(mySheetName(k), InStr(StrConv(mySheetName(k), vbNarrow) & ".", "."))) Then mySheetName(k) = Right(String(60, 0) & StrConv(mySheetName(k), vbNarrow), 60)
Next k
If mySheetName(0) > mySheetName(1) Then Sheets(j).Move Before:=Sheets(i)
Next j
Next i

'全シート保護
For i = 1 To n
Sheets(i).Protect Password:="aoken", _
DrawingObjects:=False, _
Contents:=True, _
AllowInsertingRows:=True, _
AllowDeletingRows:=True, _
Scenarios:=True, AllowFormattingCells:=True
Next i

labelE:
'元の選択位置に戻る
myActiveSheet.Activate
myActiveCell.Activate

'自動再計算とモニター更新の再開
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

回答No.1

imogasi

Excelでは、エクセル９５以来、シート名による並べ替えは、設けて無いようだ。
vbaをやるぐらいならご存じだろう。
だから
（１）出来合いのプログラムを使うか
（２）VBAでやる
しかない、のは判るよね。
（１）はhttp://www.geocities.jp/roomoftt/pc-ex-3-01.htm
http://okwave.jp/qa/q2486704.html
のような記事があるからやってみたら。
（２）ソートはバブルソートなど簡単な方だが、面倒くさい。
配列のソートもvbaでは自作だったと思う（vbではある　Array.Sort(strArray)
http://officetanaka.net/excel/vba/tips/tips40.htm
　　a.シートのセルの並べ替えを（vbaで）使う
　　Ｂ．vbaでソートプログラムを自作する
バブルソートの一例　http://www.happy2-island.com/excelsmile/smile03/capter00719.shtml
aの場合はシーと現名とソートキーを２列に別に設定して
第１列を現シート名、第２列を修正ソートキーにして（手入力かvbaで）第２列でソートしてはどうか。
その後にその順番で、vbaでシートの見た目の順番をMOVEしてはどうか。
http://www.happy2-island.com/excelsmile/smile03/capter00405.shtml
＞特定の範囲のシート
特定の都は具体的に書くこと
一般的に質問するのでなく、
本番データー必要な特徴を残した具体例を作る（１０件程度でよいだろう）ー回答ー質問者が実際（本番）の場合に合わせてコードを取捨・修正する
というステップでやるように、質問の記述を工夫してほしい。
コードを丸コピーの質問が多すぎる。
回答者が模擬具体例を想像して作って、回答者がそれでテストするのは作業が大変。
質問者はvbaの経験はあるようだから、上記をヒントに自分でやってみること。
webなど調べれば、自分でできる域にありながら、他人にやらそうとしているようだ。
細部でコードが判らなければ、その点に絞って質問すべきと思う。

補足

自分なりにいろいろ調べてどうしても解決しないので、質問していたのですが…
質問内容を否定されてしまうと、質問できなくなってしまいますね…

題目の中の"特定の範囲のシートを並べ替えをして"の説明について、以下のように具体的に記載していたのですが、わかり辛かったのでしょうか？
"３．先頭から9番目のシートから、31番目のシートをシート名でソート"

質問の仕方に問題があるご指摘をいただきまして、恐縮です。