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

Question

シート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)というようにそれぞれ順番に並べたいのです。どうすればよいのでしょうか？

Wendy02 · Accepted Answer

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

papayuka · Answer

#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)

のようになってしまうのではと思っただけです。
余計なお節介のようでした。

Wendy02 · Answer

こんにちは。
Wendy02です。

＞もうぜんぜんわけがわからなくなり、上記のようにしましたがこれでいいんですよね？
いいけれども、

＞Private Function myShCounter(ShName As String) As Long
これは要らなくなりましたね。

配列変数を使うと、ややこしいかもしれませんね。
それと、なるべくデータ型の宣言はしたほうが、その値の流れが読めるようになります。

Wendy02 · Answer

こんにちは。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

Wendy02 · Answer

こんにちは。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

papayuka · Answer

シート名は文字なので 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

Wendy02 · Answer

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

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

merlionXX さん、こんばんは。

#2です。

こんにちは。

こんにちは。

この回答への補足

こんにちは。

この回答への補足

シート名は文字なので n が 10 以上で桁が揃っていない場合は上手く並ばないので、事前に桁を揃える作業が必要と思います。

merlionXX さん、こんばんは。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング