エクセルVBAでシートの並べ替え

質問

シートAと、Aを参照しているシートBのセットを複数枚複製するVBAです。これはこれでちゃんと作動し、複製されたB(n)はA(n)を正しく参照しています。

For n = 1 To X'(Xは変数です。)
Sheets(Array("A", "B")).Copy after:=Sheets(Sheets.Count)
Next

質問は、このマクロで生成されたシートの並び替え方法です。現状ではA,B,A(2),B(2)～A(n),B(n)ですが、これをA,
A(2)～A(n)、B,B(2)～B(n)というようにそれぞれ順番に並べたいのです。どうすればよいのでしょうか？

回答No.7

Wendy02 · ベストアンサー

merlionXX さん、こんばんは。

私のコードは、1度きりなら、10以上でも、問題は出ないはずですが、まあ、シートの追加スタイルの場合の時のための修正コードを作りましたので、良かったら差し替えていただけますでしょうか？「人のコードは、さっぱりわからない」という所でしょうが、これら各々は、コードのパーツで、汎用性がありますから、後々、別な場所で使えます。

SheetOrdering プロシージャと並べ替え用の2次元配列用のBsort (バブルソート）を入れ替えていただけますでしょうか？問題がなければ、参考用でも構いません。

#4と同じ要領で、元は替えなくてよいです。

'-----------------------------------------------

Sub SheetOrdering(ByVal ShName As Variant)
Dim Shtes()
Dim i As Long
ReDim Shtes(1, 0)
With ActiveWorkbook
Shtes(0, 0) = 0
Shtes(1, 0) = ShName

For i = 1 To Worksheets.Count
　If Worksheets(i).Name Like Shtes(1, 0) & "?*" Then
　　j = j + 1
　　ReDim Preserve Shtes(1, j)
　　Shtes(0, j) = Val(Mid$(Worksheets(i).Name, InStr(1, Worksheets(i).Name, "(", 1) + 1))
　　Shtes(1, j) = Worksheets(i).Name
　End If
Next
BSort Shtes()
Application.ScreenUpdating = False
　On Error GoTo ErrHandler
　For k = 1 To UBound(Shtes, 2)
　　.Worksheets(Shtes(1, k)).Move After:=.Worksheets(Shtes(1, k - 1))
　Next
　Application.ScreenUpdating = True
　End With
ErrHandler:
　If Err.Number > 0 Then
　 MsgBox Err.Number & " : " & Err.Description
　End If
End Sub

Private Function BSort(BaseArray() As Variant)
　Dim u As Long
　Dim i As Long
　Dim j As Long
　Dim t1 As Long
　Dim t2 As String
　u = UBound(BaseArray(), 2)
　i = LBound(BaseArray(), 2)
　Do While i < u
　　j = u
　　Do While j > i
　　　If Val(BaseArray(0, i)) > Val((BaseArray(0, j))) Then '昇順
　　　　t1 = BaseArray(0, j)
　　　　t2 = BaseArray(1, j)
　　　　BaseArray(0, j) = BaseArray(0, i)
　　　　BaseArray(1, j) = BaseArray(1, i)
　　　　BaseArray(0, i) = t1
　　　　BaseArray(1, i) = t2
　　　End If
　　　j = j - 1
　　Loop
　　i = i + 1
　Loop
End Function

お礼

もう、何から何まで至れり尽せりでなんとお礼を申したらいいのやら。

完璧です。
Wendy02さん、有難うございました！

回答No.6

papayuka

#2です。
もう解決されたようなので運用上なんの問題も無いのでしょうが、、、

> やってみましたが、AB交互になってしまいました。

私は並び替えのサンプルを書いたのではないので。
ただ、シート「構M」を20枚コピーした場合などは、( )内の数字の桁が揃ってないと

構M
構M(10)
構M(11)
構M(12)
構M(13)
構M(14)
構M(15)
構M(16)
構M(17)
構M(18)
構M(19)
構M(2)
構M(20)
構M(3)
構M(4)
構M(5)
構M(6)
構M(7)
構M(8)
構M(9)

のようになってしまうのではと思っただけです。
余計なお節介のようでした。

お礼

そういうことでしたか！
まだテスト段階だったので10枚以上は試していませんでした。
やってみたら確かにそうなりました。

そこまでのご配慮、ほんとうにありがとうございます。
感激です。

回答No.5

Wendy02

こんにちは。
Wendy02です。

＞もうぜんぜんわけがわからなくなり、上記のようにしましたがこれでいいんですよね？
いいけれども、

＞Private Function myShCounter(ShName As String) As Long
これは要らなくなりましたね。

配列変数を使うと、ややこしいかもしれませんね。
それと、なるべくデータ型の宣言はしたほうが、その値の流れが読めるようになります。

お礼

ありがとうございます。
おかげさまで出来ましたが、これでなぜ今度は構Mが先にくるのか見当もつきません。これじゃダメですよねえ。

でも助かりました、有難うございます。

回答No.4

Wendy02

こんにちは。Wendy02です。

＞>本来は、Type:=2 用になっているようですが
＞数字しか入力してほしくないのでType:=1としたのですが変ですか？

# If ans = "" Or ans = False Then

実際には、"" は、入りませんね。"" は、Type:=2 にして、空の状態のまま、OK を押した場合です。

Input メソッドで、唯一、空の状態を受けられるのは、Type:=2 なのですね。全体的な流れからすると、ans は、Variant 型で使われているようにお見受けしています。 あまり大勢に影響はありませんが。

'-------------------------------------------------
これは、元のシートの後ろに入れていくように作られています。それでよかったのかしら？構M が先にあるから、先に並ぶだけです。最初のものを少し変えただけです。以下は、私の考えた方法です。

元のコードの途中

For n = 1 To ans
　Sheets(Array("構M", "構F")).Copy After:=Sheets(Sheets.Count)

'変更部分開始
For Each Sh In Array("構M", "構F")
　Call SheetOrdering(Sh)　'変更　
Next
'変更部分終了

それで、SheetOrdering を以下のものと置き換えてください。

Sub SheetOrdering(ShName As Variant)
Dim Shtes() As String
Dim Sh As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer

With ActiveWorkbook
ReDim Shtes(0)
Shtes(0) = ShName
　For i = 1 To .Sheets.Count
　 If .Sheets(i).Name Like ShName & "?*" Then
　　j = j + 1
　　ReDim Preserve Shtes(0 To j)
　　Shtes(j) = .Sheets(i).Name
　 End If
　Next
　 If j = 0 Then Exit Sub
　 BSort Shtes()
　Application.ScreenUpdating = False
　On Error GoTo ErrHandler
　For k = 1 To UBound(Shtes)
　　.Worksheets(Shtes(k)).Move After:=.Worksheets(Shtes(k - 1))
　Next
　Application.ScreenUpdating = True
　End With
ErrHandler:
　If Err.Number > 0 Then
　 MsgBox Err.Number & " : " & Err.Description
　End If
End Sub

'-------------------------------------------------
'以下そのまま(実際には使われていませんが、違っていたら、こちらで直します。）
Private Function BSort(BaseArray() As String)
'省略
End Function

お礼

もうぜんぜんわけがわからなくなり、上記のようにしましたがこれでいいんですよね？

ちゃんと作動するようです。

補足

このようにしました。

Sub TEST01()
ans = Application.InputBox("明細はあと何構分必要ですか？(￣Δ￣;)", Type:=1)
If ans = "" Or ans = False Then
Exit Sub
End If

If MsgBox(ans & "構を追加します。" _
& vbCr & "限度を設定しますか？", vbYesNo, " 確認") = vbYes Then

For n = 1 To ans
Sheets(Array("構M", "構F")).Copy After:=Sheets(Sheets.Count)

For Each Sh In Array("構M", "構F")
Call SheetOrdering(Sh) '変更
Next

Next

Else
For n = 1 To ans
Sheets("構M").Copy After:=Sheets(Sheets.Count)
Next
End If
End Sub

Sub SheetOrdering(ShName As Variant)
Dim Shtes() As String
Dim Sh As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer

With ActiveWorkbook
ReDim Shtes(0)
Shtes(0) = ShName
For i = 1 To .Sheets.Count
If .Sheets(i).Name Like ShName & "?*" Then
j = j + 1
ReDim Preserve Shtes(0 To j)
Shtes(j) = .Sheets(i).Name
End If
Next
If j = 0 Then Exit Sub
BSort Shtes()
Application.ScreenUpdating = False
On Error GoTo ErrHandler
For k = 1 To UBound(Shtes)
.Worksheets(Shtes(k)).Move After:=.Worksheets(Shtes(k - 1))
Next
Application.ScreenUpdating = True
End With
ErrHandler:
If Err.Number > 0 Then
MsgBox Err.Number & " : " & Err.Description
End If
End Sub

Private Function myShCounter(ShName As String) As Long
'シートカウンタ
Dim i As Long
Dim cnt As Long
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name Like ShName & "*" Then
cnt = cnt + 1
End If
Next i
myShCounter = cnt
End Function

Private Function BSort(BaseArray() As String)
Dim u As Long
Dim i As Long
Dim j As Long
Dim t As String
u = UBound(BaseArray())
i = LBound(BaseArray())
Do While i < u
j = u
Do While j > i
If BaseArray(j) < BaseArray(i) Then '昇順
t = BaseArray(j)
BaseArray(j) = BaseArray(i)
BaseArray(i) = t
End If
j = j - 1
Loop
i = i + 1
Loop
End Function

回答No.3

Wendy02

こんにちは。Wendy02です。

私の使っているコードから直してもよいのですが、それは、汎用性の意味が強いので、ひじょうに複雑になります。ですから、元から直したほうが早いと思いました。

以下をご覧になってください。

それから、
Application.InputBox は、コード的にみると、本来は、Type:=2 用になっているようですが、あえて、Type:=1 のままにしました。

＞　 If MsgBox(ans & "構を追加します。" _
＞　　　& vbCr & "限度を設定しますか？", vbYesNo, " 確認") = vbYes Then

この部分は、本当は、Yes/No ではないようですが、そのままにしました。
欲を言うと、シートは、CodeName で処理していくのが一番なのですが、それは、会社などで使うものにはあまり関係がありません。

Sub TEST01R()
　 Dim ans As Variant
　 Dim i As Integer
　 Dim j As Integer
　 Dim n As Integer
　 Dim m As Integer

　 ans = Application.InputBox("明細はあと何構分必要ですか？(￣Δ￣;)", Type:=1)
　 If ans = 0 Or VarType(ans) = vbBoolean Then
　　　Exit Sub
　 End If

　 If MsgBox(ans & "構を追加します。" _
　　　& vbCr & "限度を設定しますか？", vbYesNo, " 確認") = vbYes Then

　　　 i = myShCounter("構M") - 1 '追加された場合

　　　Application.ScreenUpdating = False

　　　For n = 1 To ans
　　　　 Sheets("構M").Copy After:=Sheets(Sheets("構M").Index + n - 1 + i)
　　　Next n

　　　j = myShCounter("構F") - 1
　　　For n = 1 To ans
　　　　　 Sheets("構F").Copy After:=Sheets(Sheets("構F").Index + n - 1 + j)
　　　Next n
　　　　Application.ScreenUpdating = True

　　　Else

　　　 Application.ScreenUpdating = False

　　　i = myShCounter("構M") - 1　'追加された場合
　　　For m = 1 To ans
　　　　 Sheets("構M").Copy After:=Sheets(Sheets("構M").Index + m - 1 + i)
　　　Next

　　　　Application.ScreenUpdating = True
　 End If
End Sub
Private Function myShCounter(ShName As String) As Long
'シートカウンタ
Dim i As Long
Dim cnt As Long
　For i = 1 To ActiveWorkbook.Sheets.Count
　　If Sheets(i).Name Like ShName & "*" Then
　　　cnt = cnt + 1
　　End If
　Next i
　myShCounter = cnt
End Function

お礼

Wendy02さん、有難うございます。
いつもお手数おかけしまして申し訳ありません。

補足

わたしの質問がまずかったようです。

構Fシートは構Mシートを参照しています。だから構Fシートと構Mシートを増やす場合は構Fシート(2)はペアとなる構Mシート（2）を参照しなくてはなりません。だから2枚まとめてコピーしているのです。No3のやり方だと参照が正しくなりません。

並び順ですが構Fシートと構Mシートを増やす場合、まず構Mが順番で並び、次に構Fが順番で並ぶようにしたいのですが、No2No3のやり方だと、まず構Fの順番が構Mの順番より先（左）にきてしまうんです。

> この部分は、本当は、Yes/No ではないようですが、そのままにしました。

場合により構Fシートが不要の時があります。（意味不明でしょうが、とある「限度を設定しない場合」です。）だからYesNoで聞き、Noの場合は構Mシートのみコピーするようにしています。

>本来は、Type:=2 用になっているようですが

数字しか入力してほしくないのでType:=1としたのですが変ですか？

回答No.2

papayuka

シート名は文字なので n が 10 以上で桁が揃っていない場合は上手く並ばないので、事前に桁を揃える作業が必要と思います。
汎用性が無いので、あまり良いサンプルでは無いですけど。

Sub aaa()
x = 10: i = 2
On Error Resume Next
　For n = 1 To x '(Xは変数です。)
　　Sheets(Array("A", "B")).Copy after:=Sheets(Sheets.Count)
　　Sheets(Sheets.Count - 1).Name = "A(" & Format(i, "00") & ")"
　　Sheets(Sheets.Count).Name = "B(" & Format(i, "00") & ")"
　　i = i + 1
Next
End Sub

お礼

ありがとうございます。
やってみましたが、AB交互になってしまいました。

回答No.1

Wendy02

merlionXX さん、こんばんは。

一応、こんな風でよいかと思いますが、こういうのは、実際には、思ってもみないエラーが発生することがあります。申し訳ないけれど、しばらく使ってみて、エラーが出たら、原因を考えてみてください。私は、2年間、似たようのものを使っていますが、未だに完璧とは言えません。

そういう理由で、ErrHandler を付け加えました。
なお、Sheet1 という名前のつくものは、並べ替えを除外対象にしました。

'------------------------------------------

Sub SheetOrdering()
Dim Shtes() As String
Dim sh As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer

With ActiveWorkbook
　For i = 1 To .Sheets.Count
　 If Not .Sheets(i).Name Like "Sheet*" Then
　　j = j + 1
　　ReDim Preserve Shtes(1 To j)
　　Shtes(j) = .Sheets(i).Name
　 End If
　Next
　 BSort Shtes()　'並べ替え
　Application.ScreenUpdating = False
　On Error GoTo ErrHandler
　For Each sh In Shtes
　　k = k + 1
　　.Worksheets(sh).Move Before:=.Worksheets(k)
　Next
　Application.ScreenUpdating = True
　End With
ErrHandler:
　If Err.Number > 0 Then
　 MsgBox Err.Number & " : " & Err.Description
　End If
End Sub

Private Function BSort(BaseArray() As String)
　Dim u As Long
　Dim i As Long
　Dim j As Long
　Dim t As String
　u = UBound(BaseArray())
　i = LBound(BaseArray())
　Do While i < u
　　j = u
　　Do While j > i
　　　If BaseArray(j) < BaseArray(i) Then '昇順
　　　　t = BaseArray(j)
　　　　BaseArray(j) = BaseArray(i)
　　　　BaseArray(i) = t
　　　End If
　　　j = j - 1
　　Loop
　　i = i + 1
　Loop
End Function

お礼

ありがとうございます。
下記でちゃんと作動します。

Sub TEST01()
ans = Application.InputBox("明細はあと何構分必要ですか？(￣Δ￣;)", Type:=1)
If ans = "" Or ans = False Then
Exit Sub
End If

If MsgBox(ans & "構を追加します。" _
& vbCr & "限度を設定しますか？", vbYesNo, " 確認") = vbYes Then

For n = 1 To ans
Sheets(Array("構M", "構F")).Copy After:=Sheets(Sheets.Count)

Call SheetOrdering'ここで使わせてもらいました。

Next

Else
For n = 1 To ans
Sheets("構M").Copy After:=Sheets(Sheets.Count)
Next
End If
End Sub

ところが並びが構Fの方が構Mの前になってしまうんです。構Mを溝Fの先に持っていきたいのですが、教えていただいたVBAのどこを変えればいいのかわかりません。勝手を言いますがご教示いただけませんでしょうか？