忍者ブログ
ブログ主が仕事や個人的に学んだPC系・プログラミング系(VBAとかHTML)について書いていく備忘録ブログ。 ※ここで記載する内容はあくまで「個人的に」上手くいく内容です。ご使用には十分注意してください
[26] [25] [24] [23] [21] [19] [18] [17] [16] [15] [14
Posted by - 2017.06.28,Wed
×

[PR]上記の広告は3ヶ月以上新規記事投稿のないブログに表示されています。新しい記事を書く事で広告が消えます。

Posted by 若槻風亜 - 2014.06.17,Tue
(対象)Excel VBA
(確認)Excel2003(多分2010でも使える)


今回はワークブック内のシートを新しいブックに保存する方法を
書いていこうと思います。

私がこれを使ったのは、たとえば毎日の処理でシートが徐々に
増えていくプログラムなどでした。

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

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

となります。
----------------------------------

(前提)
 1.各対象シートのB1セルに日付が入っている
 2.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(閉じる)」


--------------------------------

以上が「月が替わったら前月のシートを全て新しいブックに移す」でした。
もう少しスマートなやり方があるかもしれませんので、実際にお試しの方は
内容に合わせて改変してみてください。

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

では今回はこの辺りで。

拍手[0回]

PR
Comments
Post a Comment
Name :
Title :
E-mail :
URL :
Comments :
Pass :   Vodafone絵文字 i-mode絵文字 Ezweb絵文字
プロフィール
HN:
若槻風亜
性別:
女性
職業:
会社員
趣味:
創作、プログラミング
自己紹介:
仕事や個人で学んだことをまとめておきたかったがために備忘録ブログを立ち上げました。
あくまで自分が学んだこと・自分が出来たことなので、ご覧くださる場合は参照レベルでお願いします。
ブログ内検索
カレンダー
05 2017/06 07
S M T W T F S
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30
P R
最新トラックバック
コガネモチ
フリーエリア



Template by mavericyard*
Powered by "Samurai Factory"
忍者ブログ [PR]