VBA ２つのシートを左から２番目３番目に移動

Question

いつもお世話になります。

OSは、win10  エクセルは、2016　です。


最左のシート、「予約一覧」の
　=A1 に「11-1」
  =B1 に「11-5」と入力してコマンドボタンをクリックすれば、
　最左のシート「予約一覧」の右に　11-1　11-5　のシートを
　移動させたいです。
　12月になれば上の要領で、12-1　12-5　を移動させ　11-1　と　11-5
　は8番目の領収書の右隣りに移動したいです。

　上の記述が下記のようにしたい。

　11月
　予約一覧　11-1　11-5　抽出　空室状況　次年空室状況　請求書　領収書
　10-1　10-5　・・・・
　
　12月になると
　予約一覧　12-1　12-5　抽出　空室状況　次年空室状況　請求書　領収書
　11-1　11-5　・・・・

　いろいろと調べてみましたが難しくて手に負えません。

　ご指導頂けたら嬉しいです。

　宜しくお願いいたします。

tatsu99 · Accepted Answer

標準モジュールに登録してください。

Option Explicit
Const BHN1 As String = "予約一覧"
Const BHN2 As String = "抽出"
Const BHN3 As String = "領収証"
Public Sub シート移動()
Dim bs As Worksheet
Dim ws As Worksheet
Dim sh1 As String
Dim sh2 As String
'必須シートのチェック
Call sheet_check(BHN1)
Call sheet_check(BHN2)
Call sheet_check(BHN3)
If Worksheets(1).Name <> BHN1 Then
MsgBox (BHN1 & "の位置が不正")
Exit Sub
End If
Set bs = Worksheets("予約一覧")
sh1 = bs.Range("A1").Value
sh2 = bs.Range("B1").Value
'移動シートのチェック
Call sheet_check(sh1)
Call sheet_check(sh2)
'予約一覧～抽出の間にあるシートの移動
Call sheet_move
'A1,B1の移動
Worksheets(sh2).Move after:=Worksheets(BHN1)
Worksheets(sh1).Move after:=Worksheets(BHN1)
MsgBox ("完了")
End Sub
'シート名チェック
Private Sub sheet_check(ByVal sheet_name As String)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = sheet_name Then Exit Sub
Next
MsgBox ("シート名<" & sheet_name & ">は存在しません")
End
End Sub

'予約一覧～抽出の間にあるシートの移動
Private Sub sheet_move()
Dim i As Long
Dim last As Long
Dim scount As Long
scount = Worksheets.count
last = 0
For i = 2 To scount
If Worksheets(i).Name = BHN2 Then Exit For
last = i
Next
If last = 0 Then Exit Sub
For i = last To 2 Step -1
Worksheets(i).Move after:=Worksheets(BHN3)
Next
End Sub

GooUserラック · Answer

No.7 追加補足

全ての月シートが事前に存在しているとしていますので、存在しないものが有ったらエラーします。

GooUserラック · Answer

No.4 への補足コメントについて

動作途中で表示されて止まるならば「Sheets("○-5")」の「○」にあたる部分が半角数字で無いなど、シート名に問題があると思います。

GooUserラック · Answer

No.4 の訂正（補足コメントを見ていませんでした）

「領収書」は「領収証」に直してください。

GooUserラック · Answer

A1セルには月のみ入れて下さい。B1セルは使いません。
別なシートが増えても対応します。

Sub Sample()

Dim 月 As Long
Dim 仮 As Long

月 = Sheets("予約一覧").Range("A1").Value
　Sheets(月 & "-5").Move After:=Sheets("予約一覧")
　Sheets(月 & "-1").Move After:=Sheets("予約一覧")
　仮 = 月 + 1
　If 仮 > 12 Then 仮 = 1
　Do Until 仮 = 月
　　Sheets(仮 & "-5").Move After:=Sheets("領収書")
　　Sheets(仮 & "-1").Move After:=Sheets("領収書")
　　仮 = 仮 + 1
　　If 仮 > 12 Then 仮 = 1
　Loop

End Sub

tom04 · Answer

No.1です。

＞下記の構文に黄色の塗りが出ました。
＞Worksheets(sN).Move after:=Worksheets(1)

おそらくA1・B1セルに入力しているシート名が存在しない！いうエラーではないでしょうか？
各シート名は「11-1」・「11-5」のようになっているのですよね？
シート名は「文字列」になります。

A1・B1のセルの表示形式はどのようになっていますか？
表示形式が標準の場合、「11-1」と入力するとExcel的には「11月1日」のシリアル値に置き換えてしまいます。
その表示形式をいくら「m-d」のように設定し、「11-1」と表示させても
実データはシリアル値（43770）なので「そんなシート名はないよ！」
ってExcelが受け付けてくれないものだと思います。

※　A1・B1のセルの表示形式を「文字列」にし、
11-1　や11-5　のように入力すれば大丈夫だと思います。m(_ _)m

tatsu99 · Answer

補足要求１：
提示例では
A1=11-1
B1=11-5
の２つのシートでしたが、実はC1,D1もあるというケースもあるのですか？
又、A1のシートだけというケースもあるのですか。
（常にA1,B1の2シート限定なのですか）

補足要求２：
コマンドボタンをクリックしたとき、まず、
「予約一覧」と「抽出」の間にあるシートを「領収証」の右隣に移動すれば良いですか。
（画像では領収証になっています。領収書は誤りですよね）
12月になって
予約一覧、１１－１、１１－５、抽出、・・・領収証、１０－１、１０－５・・とならんでいて
A1=１２－１
B1=１２－５
の状態で、クリックすると
そのあとで、A1,B1で指定されたシートを「予約一覧」の右隣に移動させます。
予約一覧、１２－１、１２－５、抽出、・・・領収証、１１－１、１１－５、１０－１、１０－５・・と並びます。
これであってますか？

tom04 · Answer

こんばんは！

動かすシートは二つだけで、A1・B1に入力したシートは存在する！という前提です。

標準モジュールです。

Sub Sample1()
　Dim sN As String
　　With Worksheets("予約一覧")
　　　sN = .Range("A1")
　　　　Worksheets(sN).Move after:=Worksheets(1)
　　　sN = .Range("B1")
　　　　Worksheets(sN).Move after:=Worksheets(2)
　　　.Activate
　　End With
End Sub

※　Excel的には「11-1」のような入力だと日付と判断しシリアル値になってしまいます。
A1・B1の表示形式は文字列になっているのですかね。

※　コマンドボタンで実行したい場合は
上記標準モジュールを呼び出すコードにしてください。m(_ _)m

VBA ２つのシートを左から２番目３番目に移動

標準モジュールに登録してください。

No.7 追加補足

No.4 への補足コメントについて

No.4 の訂正（補足コメントを見ていませんでした）

A1セルには月のみ入れて下さい。

No.1です。

補足要求１：

こんばんは！

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

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

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