Excel シートを新規ブックに移動

（対象）Excel　VBA

（確認）Excel2003（多分2010でも使える）

今回はワークブック内のシートを新しいブックに保存する方法を

書いていこうと思います。

私がこれを使ったのは、たとえば毎日の処理でシートが徐々に

増えていくプログラムなどでした。

なので、今回の流れとしては

「月が替わったら前月のシートを全て新しいブックに移す」

となります。

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

（前提）

　１．各対象シートのB1セルに日付が入っている

　２．DontLookやOKLookなどを使用→詳しくはこちら

（プログラム）

　　'============================================================

　　' 月ごとにシートの抜き出し

　　'============================================================

　　Sub Nukidasi()

　　　　Dim I       As Integer

　　　　Dim MyFile  As String

　　　　Dim MyDate  As String

　　　　Dim Moji    As String

　　　　Dim WB1     As WorkBook

　　　　Dim WB2     As WorkBook

　　　　Dim WHX     As WorkSheet

　　　　'■インプットボックスで年月を指定（※1）

　　　　MyDate = InputBox("抜き出すデータの年月を西暦で入力してください(Ex: 201307)", "年月指定")

　　　　'■データが空だったり数字以外だったら処理を抜ける

　　　　If MyDate = "" Then

　　　　　　MsgBox "入力がされませんでした。処理を中断します", vbExclamation, "【報告】"

　　　　　　 Exit Sub

　　　　ElseIf Not IsNumeric(MyDate) Then　'(※2)

　　　　　　MsgBox "数字以外が入力されました。処理を中断します", vbExclamation, "【報告】"

　　　　　　Exit Sub

　　　　End If

　　　　'■指定年月に当てはまるものを新しいブックに保存していく

　　　　DontLook

　　　　'1.ブックを設定

　　　　Workbooks.Add

　　　　Set WB1 = ThisWorkbook

　　　　Set WB2 = ActiveWorkbook

　　　　WB1.Activate

　　　　'2.該当のシートを移していく

　　　　I = 1

　　　　Do Until I > ThisWorkbook.Worksheets.Count

　　　　　　Set WHX = Sheets(I)

　　　　　　Moji = Replace(Left(WHX.Range("B1").Value, 7), "/", "")　'(※3)

　　　　　　'△指定した年月と一致したら移動する

　　　　　　If MyDate = Moji Then

　　　　　　　　Sheets(I).Move After:=WB2.Sheets(WB2.Worksheets.Count) '(※4)

　　　　　　　　WB1.Activate

　　　　　　　　I = I - 1　'(※5)

　　　　　　End If

　　　　　　I = I + 1

　　　　Loop

　　　　'3.新しいブックから「Sheet*」のシートを消す

　　　　I = 1: WB2.Activate

　　　　Do Until I > WB2.Worksheets.Count

　　　　　　If Sheets(I).Name Like "Sheet*" Then

　　　　　　　　Sheets(I).Delete

　　　　　　　　I = I - 1

　　　　　　End If

　　　　　　I = I + 1

　　　　Loop

　　　　'■ファイル名をつけて保存

　　　　MyFile = ThisWorkbook.Path & "\" & MyDate

　　　　WB2.Close SaveChanges:=True, Filename := MyFile　'(※6)

　　　　OKLook

　　End Sub

（解説）

　※1

　　＝上の例だと入力させるのは1回きりだが、入力完了するまで

　　　回したい、もしくは終了を選択したい場合は以下の通り。

　　　フラグがTrueになるか処理を抜ける判断をしたら処理を抜けます。

　　－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

　　　Sub test_012()

　　　　　Dim FLG   As Boolean

　　　　　Dim MyStr As String

　　　　　Dim MSG   As String

　　　　　FLG = False

　　　　　Do

　　　　　　MyStr = InputBox("数字を入力してください", "入力")

　　　　　　If IsNumeric(MyStr) Then FLG = True

　　　　　　If Not FLG Then

　　　　　　　　MSG = MsgBox("空白、もしくは数字以外が入力されました。" & _

　　　　　　　　　　　　　　　vbCrLf & vbCrLf &  "入力を繰り返しますか？", & _

　　　　　　　　　　　　　　　vbQuestion + vbYesNo, "確認")

　　　　　　　If MSG = vbNo Then Exit Do

　　　　　　End If

　　　　　Loop Until FLG

　　　　　If Not FLG Then Exit Sub

　　　　　MsgBox MyStr & " : " & FLG

　　　End Sub

　　－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

　※2

　　＝「If Not IsNumeric(MyDate)」

　　　・・・IsNumeric（対象）　：　対象が数字か判断

　　　・・・Not ～　：　結果がTrueかFalseになる式の時、「If ○ Then」だと

　　　　　　　　　　　「Trueの時」になるが、Notがつくと「Falseの時」になる

　※3

　　＝「Replace(Left(WHX.Range("B1").Value, 7), "/", "")」

　　　・・・Left(文字列, 文字の長さ）　：　文字列の左から文字数分取得

　　　・・・Replace（文字列, 検索文字列, 置換後文字列）

　　　　　　　：　文字列に含まれる検索文字列を置換後文字列に変換する

　　　今回の場合は、「2012/11」と取った値から「/」を「」に置換して

　　　「201211」の形にした

　※4

　　＝「シート.Move After:=[ブック.]Sheets([ブック.]Worksheets.Count)」

　　　・・・シート.Move　　：　シートを移動する

　　　・・・After:=シート　：　以降で指定したシートの後ろ

　　　・・・Sheets(Worksheets.Count）　：　最後のシート

　※5

　　＝シートが1枚減ったので、その分のカウントを削っている

　※6

　　＝「ブック.Close SaveChanges:=True, Filename := ファイル名」

　　　・・・SaveChanges　：　保存して閉じるか否か

　　　・・・Filename　　：　名前をつけて保存する場合のファイル名

　　　2行にするなら「WB2.SaveAs MyFile（保存）」→「WB2.Close（閉じる）」

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

以上が「月が替わったら前月のシートを全て新しいブックに移す」でした。

もう少しスマートなやり方があるかもしれませんので、実際にお試しの方は

内容に合わせて改変してみてください。

また、今回はいちいち日付を選ぶやり方ですが、
その内「○月」と指定したらその月分を抜き出す方法を
出そうと思います（そちらもやり方はあるので）

では今回はこの辺りで。