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（閉じる）」

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

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

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

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

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

では今回はこの辺りで。

Excel CSVの読み込みと書き込み

（対象）Excel　VBA

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

今回はCSVの読み込み及び書き込みについてを書いていこうと思います。

データがCSVになっている、データをCSVに出力したいということは

意外に多いです。

それこそ色々やり方がありそうなものですが、

とりあえずここでは標準的なものを挙げてみます。

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

（前提）

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

（プログラム　読み込み）

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

　　' 読み込んだCSVをシートに展開

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

　　Sub ReadCSV()

　　　　Dim FileNo　　 As Integer

　　　　Dim MyStr　　  As String

　　　　Dim StrBox()　 As String

　　　　Dim WH1　　　  As Worksheet

　　　　Dim I As Long, J As Integer, K As Integer

　　　　DontLook

　　　　'■読込先を初期化

　　　　Set WH1 = Worksheets("作業用")

　　　　WH1.Cells.Delete

　　　　'■読み込み→写し

　　　　FileNo = FreeFile　　’(※1←↓)

　　　　Open ThisWorkbook.Path & "\テスト用データ.csv" For Input As #FileNo

　　　　MyStr = "": I = 1

　　　　Do Until EOF(FileNo)　'(※2)

　　　　　　'△一行分読み込み

　　　　　　Line Input #FileNo, MyStr　　'(※3)

　　　　　　'△区切り文字（この場合は「,」）を探す（※4）

　　　　　　StrBox = Split(MyStr, ",")

　　　　　　For J = 0 to Ubound(StrBox)

　　　　　　  WH1.Cells(I, J + 1).Value = StrBox(J)

　　　　　　Next

　　　　　　I = I + 1

　　　　Loop

　　　　'■閉じる

　　　　Close #FileNo

　　　　OKLook

　　End Sub

（解説）

　※1

　　＝指定したCSVを開く

　　★「変数 = FreeFile」

　　　　＝　変数に空いているファイル番号（FreeFile）を格納

　　★「Open　ファイル名　For 処理モード As #ファイル番号」

　　　　＝指定したファイルを指定したファイル番号で、指定した

　　　　　処理モードで開く

　　　　　※処理モード

　　　　　　・・・Input　：　入力モード（読み込み）

　　　　　　・・・Output　：　出力モード（書き込み）

　　　　　　・・・Append　：　追加モード（書き込み）

　　　　　　・・・Random　：　ランダムアクセスモード（読み込み/書き込み）

　　　　　　・・・Binary　：　バイナリモード（読み込み/書き込み）

　※2

　　＝「Do Until EOF(ファイル番号)」

　　　　指定したファイルを読み終わるまで

　※3

　　＝「Line Input #ファイル番号, 変数」

　　　　ファイルの内容を1行読み込み、その内容を変数に格納する

　※4

　　＝区切り文字で値を区切り、配列変数に格納

　　　→データをシート上に展開

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

（プログラム　書き込み）

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

　　' CSVに出力する

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

　　Sub OutPutCSV()

　　　　Dim WH1     As Worksheet

　　　　Dim I As Long, J As Long, K As Integer

　　　　'■読込先を初期化

　　　　Set WH1 = Worksheets("作業用")

　　　　'■CSV作成

　　　　WH1.Copy

　　　　ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\aaa", _

　　　　　　　　　　　　　　　FileFormat:=xlCSV

　　　　ActiveWindow.Close False

　　　　MsgBox "CSVファイルが作成されました" & vbCrLf, vbInformation, "終了報告"

　　End Sub

（解説）

　★CSVの作成

　　１．CSVにしたいシートをコピー

　　２．名前をつけて形式を選択して保存

　　　　「ブック.SaveAs FileName:=パス\ファイル名, FileFormat:=xlCSV」

　　　　※FileFormatで指定出来るファイル　：　参照URL（http://www.officepro.jp/excelvba/book_new/index9.html）

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

以上がCSVの読み込みと書き込みについてです。

もっとスマートなやり方やそれぞれの細かい内容については

グーグル先生にお尋ねくださいませ。

では、今回はこの辺りで。

Excel このブログ内で基礎的な感じでよく出るプロシージャ

今回はこのブログ内でExcelのVBAをご紹介する際
必ずと言っていいほどよく出るプロシージャを
まとめておきます。


＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
１．シートのセット
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

'■変数の宣言
Public WH1 As WorkSheet
Public WH2 As WorkSheet
Public WH3 As WorkSheet

'■シートセットのプロシージャ
Sub SheetSet()

  Set WH1 = Worksheets("シート名1")

  Set WH2 = Worksheets("シート名2")

  Set WH3 = Worksheets("シート名3")

End Sub

―――――――――――――――――――――――

これを作っておくと、たとえば

Sub AAA ()

　　SheetSet '←これで呼び出し

　　WH1.Range("A1").Value =　"ｈｈｈ"

End Sub

のように使えます。
上でやっているのは、WH1（＝シート名1）の
A1セルに「ｈｈｈ」を格納する、です。


シートのセットを変数で行っておく利点は、

　１．シート名が変更になった時にそこだけ
　　　直せば済む
　２．シートのプロパティが絶対予測で出てくる

があります。
ブログ主はExcelでプログラミングする際は
絶対に使うプロシージャの１つです。

---

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
２．描画の停止と開始等々
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

'■描画の停止他

Sub DontLook()

  '画面の移動を見せない

  Application.ScreenUpdating = False

  '確認メッセージを出さない

  Application.DisplayAlerts = False

  'マクロの動作が起因するイベント発生を抑制

  Application.EnableEvents = False

End Sub

このマクロを入れておくだけで画像のちらつきがなくなります。

ちなみにこの反対はこちら

'■描画の開始他
Sub OKLook()

  '画面の移動を見せる

  Application.ScreenUpdating = True

  '確認メッセージを出す

  Application.DisplayAlerts = True

  'マクロの動作が起因するイベント発生を抑制しない

  Application.EnableEvents = True

End Sub

ちなみに使い方は

Sub BBB ()

　　DontLook

　　（作業）

　　OKLook

End Sub

という感じです。
値を次々に入れていく、などの作業の時は
あった方が目に痛くない優しいシステムに
なるのではないかと思います。

１番と併せて、ブログ主が絶対に使うプロシージャです。

---

ということで、このブログ内でよく使われる
プロシージャでした。

Access 日本語が含まれていたら拒否する

（対象）Access　VBA
（確認）Access2010


今回は入力内容に日本語が含まれていたら
拒否する方法です。

―――――――――――――――――――――――――

○ソース

―――――――――――――――――――――――――

  '○日本語が含まれていたら拒否する
  Dim Str1 as String

  Str1 = Me.コントロール.Value

  If Str1 Like "*[!0-9a-zA-Z]*" Then

    MsgBox "数字とアルファベット以外は禁止です", vbCritical, "報告：日本語の禁止"

    Me.コントロール.Value = ""

    Me.コントロール.SetFocus

    Exit Sub

  End If

―――――――――――――――――――――――――

○解説

―――――――――――――――――――――――――

1行目から順番に、

　１．文字型の変数（Str1）を宣言
　２．変数に調べたい文字を格納
　３．変数の中身に数字・アルファベット以外が
　　　入っているかどうかの判断（[!○○]で「○○以外」）
　４～７．入っていた時の処理→処理抜け

「あ‐ん」「ア‐ン」「亜-黑」で調べる方法もありますが、
どちらかというとこちらの方が楽でしょうか。

コメント返信

コメントの削除依頼なさった方へ返信