EXCEL VBAで別ファイル作成

Question

エクセル97です。

エクセルファイル AAA.xls のすべてのワークシートのうち、セルA1に TRUE がはいっているもの、（枚数はそのときにより不定です。）のみをコピーして、別のエクセルファイルを作成したいのです。
その際、新しいファイルに貼り付けるのは書式と値のみで、シート名は 元ファイルのシート名と同じにしたいのです。

どのようなVBAを書けばよいかご教示ください。
（AAA.xls にはワークシート以外にグラフシートやダイアローグシートが入っています。）

ja7awu · Accepted Answer

> ダイアローグシートが入っているとそこでエラーになるようです。 

なるほど納得で～す。グラフだけで、これを入れないでテストしていました。
ダイアログって始めて操作しました。参考になった点があって良かったです。

>ワ－クシート以外のシートはコピー不要です。

そうだったんですか。最初に確認すべきでしたね。
今度は、大丈夫と思います。　 

Sub test()
Dim NewObj As Workbook
Dim Sh As Integer
Dim Shn As String
Dim Shc As Integer
Dim N As Integer
Set NewObj = Workbooks.Add
Application.DisplayAlerts = False
For Sh = 1 To ThisWorkbook.Worksheets.Count
　　ThisWorkbook.Activate
　　Shn = Worksheets(Sh).Name
　　If Worksheets(Sh).Range("A1").Value = True Then
　　　　Shc = Shc + 1
　　　　Worksheets(Sh).Cells.Copy
　　　　If Shc > NewObj.Sheets.Count Then
　　　　　　NewObj.Sheets.Add after:=Sheets(NewObj.Sheets.Count)
　　　　End If
　　　　NewObj.Sheets(Shc).Activate
　　　　Selection.PasteSpecial Paste:=xlValues
　　　　Selection.PasteSpecial Paste:=xlFormats
　　　　For N = 1 To NewObj.Sheets.Count
　　　　　　If NewObj.Sheets(N).Name = Shn Then
　　　　　　　　NewObj.Sheets(N).Delete
　　　　　　　　Exit For
　　　　　　End If
　　　　Next N
　　　　ActiveSheet.Name = Shn
　　　　ActiveSheet.Range("A1").Select
　　End If
Next Sh
NewObj.Sheets(1).Select
NewObj.SaveAs "C:\bbb.xls"
NewObj.Close
Application.DisplayAlerts = True
Set NewObj = Nothing
End Sub

ja7awu · Answer

> 保存する時の保存場所、および新しいファイルの名前はそのとき操作する人間が
> 任意で設定するためにはどうすればいでしょうか？

具体的にどの時点で、どのような方法で指定したいのかが分からないので、
いろいろな方法があって、いちがいには言えません。

まぁ、操作性が良いのではないかと思われる方法として、セルA1に TRUE と入力
した一番左側のシートで、セルA2とかに フォルダ名を、A3にファイル名を記述する
方法ですね。

フォルダ名、ファイル名とも幾つか選択するような状況なら、コンボボックスで
リストから指定するようにすれば良いでしょう。

あとは、マクロ起動時、ダイアログを出して、入力する方法もあります。
ただ、既設のホルダ名でないといけませんので、その辺をチェックするコードが
必要になるでしょう。

ja7awu · Answer

Excel97 SR-1 で確認しましたが、正常に動作します。イミディエイトウィンドウに下記のように記述すると 3とか -4167 の数字が返りませんか？ ? Sheets(1).type また、同じように下記のように記述すると -4167 が返りませんか? ? xlWorksheet -4167 ＶＢＥのメニューから[ツール]-->[参照設定]で「参照不可」になっているライブラリーは、ありませんか？ありましたら、設定をやり直してください。 SRも確認してください。

ja7awu · Answer

そうですか。Excel97 では、確認しませんでした。

それでは、お聞きしますが、先程も書きましたが、

> グラフシートやダイアローグシートが入っています

というこの「グラフシートやダイアローグシート」は、新しい
ブックにコピーするのですか？しないのですか？

ja7awu · Answer

新規で作ってみましたのでテストしてみてください。

ただ、質問内容に書いてある、下記のことですが

> （AAA.xls にはワークシート以外にグラフシートやダイアローグシートが
>　入っています。）

これは、入っているから、どうするということを書かないと、どうすれば
いいのか分かりません。

取り敢えず、ワークシート以外は、そのままコピーするようにしました
ので、不要の際は、修正してください。
Else の３行を削除すればいいでしょう。たぶん。

Sub test()
Dim NewObj As Workbook
Dim Sh As Integer
Dim Shn As String
Dim Shc As Integer
Dim N As Integer
Set NewObj = Workbooks.Add
Application.DisplayAlerts = False
For Sh = 1 To ThisWorkbook.Sheets.Count
　　ThisWorkbook.Activate
　　Shn = Sheets(Sh).Name
　　If Sheets(Sh).Type = xlWorksheet Then
　　　　If Sheets(Sh).Range("A1").Value = True Then
　　　　　　Shc = Shc + 1
　　　　　　Sheets(Sh).Cells.Copy
　　　　　　If Shc > NewObj.Sheets.Count Then
　　　　　　　　NewObj.Sheets.Add after:=Sheets(NewObj.Sheets.Count)
　　　　　　End If
　　　　　　NewObj.Sheets(Shc).Activate
　　　　　　Selection.PasteSpecial Paste:=xlValues
　　　　　　Selection.PasteSpecial Paste:=xlFormats
　　　　　　For N = 1 To NewObj.Sheets.Count
　　　　　　　　If NewObj.Sheets(N).Name = Shn Then
　　　　　　　　　　NewObj.Sheets(N).Delete
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next N
　　　　　　ActiveSheet.Name = Shn
　　　　　　ActiveSheet.Range("A1").Select
　　　　End If
　　Else
　　　　Shc = Shc + 1
　　　　NewObj.Sheets.Add after:=Sheets(NewObj.Sheets.Count)
　　　　ThisWorkbook.Sheets(Sh).Copy Before:=NewObj.Sheets(Shc)
　　End If
Next
NewObj.Worksheets(1).Select
NewObj.SaveAs "C:\bbb.xls"
NewObj.Close
Application.DisplayAlerts = True
Set NewObj = Nothing
End Sub

ja7awu · Answer

横レス失礼します。

> ためしたところエラーになってしまいました。

No.1のコードですが、ちょっと気付いたことですが、多分ここではないでしょうか。

Application.SheetsNewWorkbook = 1 
　　　↓
Application.SheetsInNewWorkbook = 1

あと、A1に入れる TRUE は、文字列は、少ないと思いますので、どちらでも
いいように　↓のようにしたら如何でしょうか？

if Thisworkbook.Sheets(intSheetCnt).Range("A1").Value = "TRUE" Then 
　　　↓
If ThisWorkbook.Sheets(intSheetCnt).Range("A1").Text = "TRUE" Then


上書き確認メッセージは、多分いらないと思いますので、前後に

Application.DisplayAlerts = False
Application.DisplayAlerts = True

を入れたら良いかと思います。

miya_777 · Answer

※TRUEは、文字でTRUEとします。

Dim intSheetCnt as Integer

'これで新規ブックでのシート数を１にします
Application.SheetsNewWorkbook = 1

For intSheetCnt = 1 To Thisworkbook.Sheets.Count

　if Thisworkbook.Sheets(intSheetCnt).Range("A1").Value = "TRUE" Then
　　Workbooks.Add
　　Thisworkbook.Sheets(intSheetCnt).Copy Activeworkbook.Sheets(1)

　　'最初にあった要らないシートを削除
　　Activeworkbook.Sheets(1).Delete

　　'保存するファイル名はCドライブ直下でシート名　ここはお好みで
　　Activeworkbook.SaveAs "C:\" & Thisworkbook.Sheets(intSheetCnt).Name & ".xls"

　　Activeworkbook.Close 
　EndIf
Next

EXCEL VBAで別ファイル作成

> ダイアローグシートが入っているとそこでエラーになるようです。

> 保存する時の保存場所、および新しいファイルの名前はそのとき操作する人間が

Excel97 SR-1 で確認しましたが、正常に動作します。

この回答への補足

そうですか。

新規で作ってみましたのでテストしてみてください。

横レス失礼します。

※TRUEは、文字でTRUEとします。

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

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

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

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