複数のシートを別ブックにコピーして保存したい

毎回、シート数が変動するEXCELファイルの、表示されているシートのみ（非表示シート有）を、
別のブックにコピーして、セルの書式と値を貼付けし、
元ファイルのシート名と同じシート名を付けたいのですが、
どんなVBAを組めば良いでしょうか？
下記の様に作成してみましたが、ファイル自体がコピペされてしまう様で、
自分のイメージした通りに動きません・・・。
ご教授の程、宜しくお願いいたします。

Sub データ書き出し()
Dim ws As Worksheet
Dim i As Long
With ActiveWorkbook
i = Worksheets.Count
For j = 1 To i

ThisWorkbook.Worksheets(j).Cells.Copy
.Worksheets(j).Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Next j
Application.CutCopyMode = False
.SaveAs "月別DATA_"
End With
End Sub

No.3 ベストアンサー 回答者： myRange 回答日時： 2010/01/27 16:17

質問の文言と提示のコードには矛盾点、疑問点がありますが、

要するに以下のようなことですか？

元ブック　：　ThisWorkbook
コピー先　：　まとめ.xls

だと仮定して、、

●元ブックの表示シートを"まとめ.xls"にコピーする

●コピーするときは、"まとめ.xls”に既にコピーしてあるシートの次からコピーする
（要するに、まとめ.xlsのシートはコピーするたびに増えていくということです）

●コピーは書式と値のみにする

●コピーしたシート名は、元ブックのシート名と同じにする
（ま、これはシートをコピーすればいいわけですが）
　

もし、このようなことなら以下のコードでもできます。
　
'--------------------------------------------
Sub test()
　Dim MatomeBK As Workbook
　Dim MotoBK As Workbook
　Dim Sht As Worksheet

　Set MotoBK = ThisWorkbook
　Set MatomeBK = Workbooks("まとめ.xls")

　For Each Sht In MotoBK.Worksheets
　　　If Sht.Visible = True Then
　　　　　Sht.Copy After:=MatomeBK.Worksheets(MatomeBK.Worksheets.Count)
　　　　　ActiveSheet.Cells.Copy
　　　　　ActiveSheet.Cells(1).PasteSpecial Paste:=xlValues
　　　　　Application.CutCopyMode = False
　　　End If
　Next Sht

'●　MatomeBK.Close True 'まとめ.xls の上書き保存＆CLOSE

End Sub
'----------------------------------------------------

それから、コピー先にコピー元と同じシート名があったらどうするかなど
処理の流れを実際に即しても少し詳しく説明する必要があるでしょう。
以上です。
　
　

この回答へのお礼

ご回答ありがとうございました。
お返事が遅くなってしまい、申し訳ありません。
無事にマクロを実行することが出来ました。
ご親切に教えて頂き、ありがとうございました。

お礼日時：2010/01/28 16:49

No.8 回答者： zap35 回答日時： 2010/01/29 01:07

＃０７です

＞セルの書式と値を貼付けし
の意味は迷いますね。
もし数式は値に置き換えて、なおかつ書式や列の幅は元のシートのままにするという意味であれば、マクロは以下になります

Sub Macro1()
Dim wkArray()
Dim idx, cnt As Integer
　For idx = 1 To Worksheets.Count
　　If Worksheets(idx).Visible Then
　　　cnt = cnt + 1
　　　ReDim Preserve wkArray(1 To cnt)
　　　wkArray(cnt) = Worksheets(idx).Name
　　End If
　Next idx
　Worksheets(wkArray).Copy

　For idx = 1 To Worksheets.Count
　　Worksheets(idx).Cells.Copy
　　Worksheets(idx).Range("A1").PasteSpecial _
　　　　　 paste:=xlPasteValues
　　Application.CutCopyMode = False
　Next idx
End Sub

ただしファイルのセーブまでは書いていませんがあしからず。

No.7 回答者： zap35 回答日時： 2010/01/28 21:07

＞セルの書式と値を貼付けし

これって値貼り付けではなく、普通のコピーでよいのですか？

表示されているシート(.Visible=True)のみを別ブックにコピーするマクロの例です。お試しください。

Sub Macro1()
Dim wkArray()
Dim idx, cnt As Integer
　For idx = 1 To Worksheets.Count
　　If Worksheets(idx).Visible Then
　　　cnt = cnt + 1
　　　ReDim Preserve wkArray(1 To cnt)
　　　wkArray(cnt) = Worksheets(idx).Name
　　End If
　Next idx
　Worksheets(wkArray).Copy
End Sub

No.6 回答者： avanzato 回答日時： 2010/01/28 17:37

#1です。

すみません。
値の貼り付けが意図的なものかと思っていました。
書式も貼り付けるのであれば
'Workbooks(NewWorkBookName).Worksheets(1).Range("A1").PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '貼付け
↑の部分を↓に変更してください。
Workbooks(NewWorkBookName).Activate
ActiveSheet.Paste '貼付け

本当は
'Workbooks(NewWorkBookName).Worksheets(1).Range("A1").Paste
としたいところですが
メソッドが対応していない為構文エラーになります。

No.5 回答者： avanzato 回答日時： 2010/01/28 11:18

#1です。

度々すみません。
解決になるか分かりませんが元々のプログラムを動作するように修正しました。
Sub データ書き出し()
　　Dim ws As Worksheet
　　Dim j As Integer
　　Dim ThisWorkBookName As String
　　Dim NewWorkBookName As String
　　Dim ThisSheetName As String
　　Dim FilePath As String
　　Dim InWorkSheetCount As String
　　InWorkSheetCount = Application.SheetsInNewWorkbook
　　Application.SheetsInNewWorkbook = 1 '新しいブックのシート数を1とする
　　FilePath = ActiveWorkbook.Path & "\" '起動パス
　　ThisWorkBookName = ActiveWorkbook.Name 'コピー元の名前を格納
　　Application.DisplayAlerts = False '警告表示しない
　　Application.ScreenUpdating = False '画面更新しない
　　For j = 1 To Worksheets.Count 'シートの数分ループ
　　　　Workbooks.Add '新しいブックの追加
　　　　NewWorkBookName = ActiveWorkbook.Name '新しいブックの名前を格納
　　　　Workbooks(ThisWorkBookName).Activate 'コピー元をアクティブ
　　　　ThisSheetName = ThisWorkbook.Worksheets(j).Name 'コピー元シート名を格納
　　　　ThisWorkbook.Worksheets(j).Cells.Copy 'シート内全コピー
　　　　Workbooks(NewWorkBookName).Worksheets(1).Range("A1").PasteSpecial _
　　　　Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '貼付け
　　　　Workbooks(NewWorkBookName).SaveAs Filename:=FilePath & ThisSheetName & ".xls" '起動パスにシート名で保存
　　　　Workbooks(ThisSheetName & ".xls").Close 'コピー済ファイルを閉じる
　　Next j 'ループ　戻る
　　Application.DisplayAlerts = True '警告表示する
　　Application.ScreenUpdating = True '画面更新する
　　Application.CutCopyMode = False 'コピー解除
　　Application.SheetsInNewWorkbook = InWorkSheetCount '新しいブックのシート数を実行前に戻す
　　MsgBox ("完了")
End Sub

この回答へのお礼

ご回答ありがとうございます。
お返事が遅くなり、申し訳ございません。
このマクロを実行しましたところ、シートごとに、セルの値のみが貼り付けられたブックが出来てしまいました。
私の勉強不足だと思うので、追々勉強して、絶対に実行させたいと思っております。
avanzato様には、環境のことからいろいろ教えて頂き、とても勉強になりました。
本当にどうもありがとうございました。

お礼日時：2010/01/28 16:55

No.4 回答者： avanzato 回答日時： 2010/01/28 10:15

#1です。

そもそもこのエラーは構文の誤りで発生していると言うわけではありません。
コピーメソッドを使用するとメモリーを消費します。
この時のメモリーはパソコンの物理メモリー・仮想メモリーと言うことではなくエクセル自体が自己動作用に確保しているメモリーです。
このメモリーの開放方法は対象エクセル自体を終了することで開放されます。
出来たり出来なかったりというのはその時のエクセル使用可能メモリーの残量が影響しています。

参考URLの
If iCounter Mod 100 = 0 Thenはループの100回目と200回目にだけ処理を実行するという意味です。
質問者様が今回行おうとしている対象シートが100未満であればこのIFは全てFalseになります。

今回の場合、自己のシートをコピーしブックとして保存終了する為 参考URLはあまり意味が無かったかもしれません。

質問者様の対象ブックがどれだけの大きさでどのくらいメモリーを消費しているか分かりませんが、もし明らかに無理がある感じでしたら処理の流れ自体を変更する必要があります。

例
(1)
自己ブックの保存をする。
↓
自己ブックのコピーファイルＡを作成する。
↓
(2)
Ａを開く。
↓
(3)
Ａのシートを順次「新規ブック」に「移動」し、シート名で保存終了する。
↓
Ａが開かれているか監視
　開かれていないのなら(4)へ進む
↓
実行エラー1004を監視
　エラーが無ければ(3)に戻る
　エラーがあればＡを保存終了した後(2)に戻る
↓
(4)
Ａを削除
↓
終了

と言った感じになります。
実際にプログラムを作ったわけではありませんので確実と言えるか分かりませんが・・・。

No.2 回答者： avanzato 回答日時： 2010/01/27 13:54

#1です。

そのエラーについての原因と対策はこちらになります。
http://support.microsoft.com/kb/210684/ja
上記サイトの最下部に対策が載っていますのでお試しください。
恐らくパッっと読んだだけでは意味が分からないかと思いますので熟読してください。
（私も最初意味が分かりませんでした。）

この回答へのお礼

教えていただいたサイトを熟読し、サイトにあった下記の部分を私なりに組み合わせてみました。
『 　'Uncomment this code for the workaround:
　'Save, close, and reopen after every 100 iterations:
　If iCounter Mod 100 = 0 Then
　oBook.Close SaveChanges:=True
　Set oBook = Nothing
　Set oBook = Application.Workbooks.Open("c:\test2.xls")
End If』

が、ある時は1シートずつブックが作成され、ある時は同じエラーが出てしまい、
ある時はファイルが勝手に閉じてしまって・・・。

私の勉強不足なのは重々承知ですが、対応をお教え頂けませんか？

お礼日時：2010/01/27 15:57

No.1 回答者： avanzato 回答日時： 2010/01/27 12:59

こんにちは。

前にも同じ質問があり回答をしましたがこちらでいかがでしょうか？
Sub Sample()
　　Dim FilePath As String
　　Dim ObjWorkSheet As Worksheet
　　Dim SheetNm As String
　　FilePath = ActiveWorkbook.Path & "\"
　　Application.DisplayAlerts = False
　　For Each ObjWorkSheet In Worksheets
　　　　SheetNm = ObjWorkSheet.Name
　　　　Sheets(SheetNm).Copy
　　　　ActiveWorkbook.SaveAs Filename:=FilePath & SheetNm & ".xls"
　　　　ActiveWorkbook.Close
　　Next
　　Application.DisplayAlerts = True
　　MsgBox ("完了")
End Sub

この回答へのお礼

ご回答ありがとうございます。
VBA初心者の為、さらに質問させてください。

Sheets(SheetNm).Copy

の所で、『Worksheetクラスのcopyメソッドが失敗しました』というエラーが出てしまいます。
これは何が原因でしょうか？

お礼日時：2010/01/27 13:23