EXCEL VBAで別ファイル作成

質問

エクセル97です。

エクセルファイル AAA.xls のすべてのワークシートのうち、セルA1に TRUE がはいっているもの、（枚数はそのときにより不定です。）のみをコピーして、別のエクセルファイルを作成したいのです。
その際、新しいファイルに貼り付けるのは書式と値のみで、シート名は 元ファイルのシート名と同じにしたいのです。

どのようなVBAを書けばよいかご教示ください。
（AAA.xls にはワークシート以外にグラフシートやダイアローグシートが入っています。）

回答No.6

ja7awu · ベストアンサー

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

なるほど納得で～す。グラフだけで、これを入れないでテストしていました。
ダイアログって始めて操作しました。参考になった点があって良かったです。

>ワ－クシート以外のシートはコピー不要です。

そうだったんですか。最初に確認すべきでしたね。
今度は、大丈夫と思います。　

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

お礼

何度もすみません。今度はうまく行きました。有難うございます。
最後にもう一つだけ教えて下さい。

保存する時の保存場所、および新しいファイルの名前はそのとき操作する人間が任意で設定するためにはどうすればいでしょうか？

回答No.7

ja7awu

> 保存する時の保存場所、および新しいファイルの名前はそのとき操作する人間が
> 任意で設定するためにはどうすればいでしょうか？

具体的にどの時点で、どのような方法で指定したいのかが分からないので、
いろいろな方法があって、いちがいには言えません。

まぁ、操作性が良いのではないかと思われる方法として、セルA1に TRUE と入力
した一番左側のシートで、セルA2とかに フォルダ名を、A3にファイル名を記述する
方法ですね。

フォルダ名、ファイル名とも幾つか選択するような状況なら、コンボボックスで
リストから指定するようにすれば良いでしょう。

あとは、マクロ起動時、ダイアログを出して、入力する方法もあります。
ただ、既設のホルダ名でないといけませんので、その辺をチェックするコードが
必要になるでしょう。

お礼

ありがとうございました。

回答No.5

ja7awu

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

イミディエイトウィンドウに下記のように記述すると 3とか -4167 の
数字が返りませんか？

? Sheets(1).type<Enter>

また、同じように下記のように記述すると -4167 が返りませんか?

? xlWorksheet<Enter>
-4167

ＶＢＥのメニューから[ツール]-->[参照設定]で「参照不可」になっている
ライブラリーは、ありませんか？
ありましたら、設定をやり直してください。

SRも確認してください。

お礼

原因がわかりました。
いろいろテストしてみたところ元のファイルがワークシートだけで構成されていればうまく動くのですが、ダイアローグシートが入っているとそこでエラーになるようです。
どう書き換えればいいのでしょうか？お手数をおかけしますがよろしくお願いします。

補足

ありがとうございます。
さきほどのエラーは自宅のエクセル2000での結果です。
ワ－クシート以外のシートはコピー不要です。
イミディエイトウィンドウに下記をコピー＆ペーストしエンターキーをおしたら「コンパイルエラー　修正候補　式」と出ました。
「参照不可」になっているライブラリーは、ありませんでした。
よろしくおねがいします。

回答No.4

ja7awu

そうですか。Excel97 では、確認しませんでした。

それでは、お聞きしますが、先程も書きましたが、

> グラフシートやダイアローグシートが入っています

というこの「グラフシートやダイアローグシート」は、新しい
ブックにコピーするのですか？しないのですか？

回答No.3

ja7awu

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

ただ、質問内容に書いてある、下記のことですが

> （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

お礼

ありがとうございました。あたらしいファイルBook1が作成され、シートもコピーされましたが。
実行時エラー438「オブジェクトはこのプロパティまたはメソッドをサポートしていません。」と出て止まってしまいます。

「デバックします」を選択すると、
　　If Sheets(Sh).Type = xlWorksheet Then
の部分がひっかかっているようでした。

どうすればいいですか？

回答No.2

ja7awu

横レス失礼します。

> ためしたところエラーになってしまいました。

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

を入れたら良いかと思います。

お礼

有難うございます。
うごきました。ただ、
If ThisWorkbook.Sheets(intSheetCnt).Range("A1").Text = "TRUE" Then
が、エラーになったので
If ThisWorkbook.Sheets(intSheetCnt).Range("A1") = True Then
に変えてみました。以下のとおりです。（A1に入るtrueは文字列ではなく関数の答えです。）
今回、A1がTrueだったのは3枚のシートでしたが、結果、空白のシートをそれぞれ1枚あるファイルが3つ出来ただけでした。
ほしいのはA1がTrueのシートの書式と値を貼り付けた3つ（今回の場合は）のシートを持つ新しいファイルひとつなのですがどうすればいいのでしょうか？

Sub test()
Dim intSheetCnt As Integer
'これで新規ブックでのシート数を１にします
Application.SheetsInNewWorkbook = 1
For intSheetCnt = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(intSheetCnt).Range("A1") = True Then
Workbooks.Add
ThisWorkbook.Sheets(intSheetCnt).Copy ActiveWorkbook.Sheets(1)
'最初にあった要らないシートを削除
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(1).Delete
Application.DisplayAlerts = True
' '保存するファイル名はCドライブ直下でシート名　ここはお好みで
' ActiveWorkbook.SaveAs "C:\" & ThisWorkbook.Sheets(intSheetCnt).Name & ".xls"
'
' ActiveWorkbook.Close
End If
Next
End Sub

回答No.1

miya_777

※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

お礼

さっそくありがとうございます。

ためしたところエラーになってしまいました。