シートを別のブックに複数自動コピー

質問

初質問です。よろしくお願いします。
マクロを使って、あるブックのシート（２０から５０枚程度）を、別の貼り付け先のブックに自動的にコピーしようとすると、１０回をすぎたあたり（必ずしも一定せず）で
「実行時エラー'1004': WorksheetクラスのCopyメソッドが失敗しました。」
というエラーと共にマクロが止まり、デバッグしようとすると
「ActiveSheet.Copy After:=Workbooks("貼り付け先ブック.xls").Sheets("○○シート")」
のところで止まっています。

マクロの記述内容は以下の通りです。

Sheets("貼り付け元シート").Activate
ActiveSheet.Copy After:=Workbooks("貼り付け先ブック.xls").Sheets("○○シート")
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
Windows("貼り付け元ブック.xls").Activate

・・・以下貼り付け元シートを変えつつ複数回繰り返し

これができる様になれば非常にラクになるので、ぜひご教授願います。

回答No.4

papayuka · ベストアンサー

#2です。

情報は小出しにしないで開示しましょう。
グラフがあるのなら話は大きく変わります。

単純なオートシェイプなら pWS.Cells.PasteSpecial Paste:=xlPasteAll　を　pWS.Paste　にすると出来ますが、グラフとなるとデータリンク元の問題が出ます。
そうすると結局 toorukunさんの元マクロと同じ方法を使わざるを得なくなります。（使わずにやるとそれはそれで面倒）
元マクロのエラー原因は不明ですが、下記のマクロで100シート程コピーしてみましたがエラーにはなりませんでした。（Excel2000）

Sub Test1()
Dim pBook As Workbook
Dim cWS As Worksheet, pWS As Worksheet

Set pBook = Workbooks("貼り付け先ブック.xls")
Set cWS = Workbooks("貼り付け元ブック.xls").Worksheets("Sheet1")
For i = 1 To 5
　　'テストとしてセル A1 に 1～5を入れて作る
　　 cWS.Range("A1").Value = i
　　 cWS.Copy after:=pBook.Worksheets(pBook.Worksheets.Count)
　　 Set pWS = ActiveSheet
　　 pWS.Cells.Copy
　　 pWS.Cells.PasteSpecial Paste:=xlValues
　　 On Error Resume Next
　　 pWS.Name = i
　　 Application.CutCopyMode = False
Next i

End Sub

お礼

早速の対応ありがとうございました。
シート数を２０にして実行してみたところ、なぜか１１回貼り付けたところで暴走し、貼り付け元シートが「自分自身」に１２回目～２０回目の貼り付けを行うという珍現象となりました・・・。もしかすると１１回ぐらいで何かの上限に触れているのかもしれません。

回答No.8

papayuka

#2です。

うーん、、、
こちらでは新規ブックにグラフを作り試しましたが問題なく動きます。

＊ 新規ブックなら50回でもＯＫ
＊ マクロだと最初のシート数 + 11枚しかシートをコピー追加出来ない
＊ 手作業でシートコピーは何枚でも可能

ブックが変になっているのかなぁ、、、

シートの構成や使用セルのアドレス（A1:C10にあるデータでグラフを作っているとか）、コピー時に書き換えているデータ内容、セルアドレス等の細かい情報と実際のマクロを提示されて、こちらで再現出来れば良いのですが、文を読んで想像だけで書いてる現状ではこの辺が限界のようです。

お礼

結局、貼り付けシートを２つにしても止まる、止まるのはペースト時ではなくコピー時、軽いグラフなら止まらない、等々の事象が分かってきました。ということは貼り付ける元のシートの重さに問題がありそうですのて、この筋でまた調べてみます。色々ありがとうございました。

回答No.7

papayuka

#2です。

新規シートの追加は可能なようですが、シートのコピーだと上手く行かないような感じですね。

２つのブックを並べて、貼り付け元ブックの該当シートを Ctrlキーを押しながら貼り付け先ブックにドラック＆ドロップするとシートがコピーされますよね？
これの作業は手作業で20回出来るのでしょうか？

貼り付け元ブックの該当シートのオブジェクト名は
Sheet1111111111111111111111111
のようになってませんよね？

お礼

朝早くからすいません。手作業での貼り付けはできます。現状では、１２枚からはそれで処理しているところです。また、「Sheet1111111111111111111111111」という現象は出ていません。

回答No.6

papayuka

#2です。

解かりませんね。

もう一度聞きますが、サンプル通りで暴走しますか？
新規ブックを２つ立ち上げて、

Set pBook = Workbooks("Book1")
Set cWS = Workbooks("Book2").Worksheets("Sheet1")

のような環境で試しても同様でしょうか？
サンプルだと A1セルに数字が入るので確認しやすいと思います。

> 貼り付け先ブックには１２回以上はどうしても貼り付けられない

貼り付け先ブックのシートが1枚だとしたら、20回ループさせるとシートが21枚になるハズですが、13枚までしか出来ないという意味でしょうか？それとも21枚出来るけど、13枚以降はデータが同じシートになってしまうって意味でしょうか？13枚以降はデータが同じって事はないですよね？

お礼

サンプル通りで貼り付け対象が白紙のシートの場合、５０回でも問題なく動きます。それを実際に貼り付けたいグラフ混じりのシートにすると「１１回」までしか貼り付きません。また、貼り付け先ブックに元々シートが１枚あっても３枚あっても、実際に貼り付けられる数は「１１枚」になります。総計だと１２枚か１４枚になるわけです。また、その１１枚目が９回「上書きで」貼り付けられています。ブックを分けるのは試してみます。

回答No.5

papayuka

#2です。

サンプル通りでも暴走しますか？
原因は Set pWS = ActiveSheet だと思われます。
アクティブシートを見失う何かがあるのかな？

Set pWS = ActiveSheet
を
Set pWS = pBook.Worksheets(pBook.Worksheets.Count)

に変えるとどうでしょう？

お礼

毎度すいません。
試したところ、「自分自身」を複写しなくなった代わりに、１１回目に貼り付けたシートを１２回目から２０回目の９回分複写するという現象になりました。
貼り付け先ブックには１２回以上はどうしても貼り付けられない、ということのようです。やはり何かの制限でしょうか？

回答No.3

papayuka

#2です。

会員リストのようなものがあって、そこから個人別シートに VLookup 関数等でデータを引っぱってくるようになっており、値のみに置き換えた個人別シートを別ブックに作りたいって感じかな。

上記イメージでサンプルを直しました。
試すならテスト環境で。

Sub Test()
Dim pBook As Workbook
Dim cWS As Worksheet, pWS As Worksheet

Set pBook = Workbooks("貼り付け先ブック.xls")
Set cWS = Workbooks("貼り付け元ブック.xls").Worksheets("Sheet1")

For i = 1 To 5
　　'テストとしてセル A1 に 1～5を入れて作る
　　cWS.Range("A1").Value = i
　　Set pWS = pBook.Worksheets.Add _
　　　　(after:=pBook.Worksheets(pBook.Worksheets.Count))
　　cWS.Cells.Copy
　　pWS.Cells.PasteSpecial Paste:=xlPasteAll
　　pWS.Cells.Copy
　　pWS.Cells.PasteSpecial Paste:=xlValues
　　On Error Resume Next
　　pWS.Name = i
　　Application.CutCopyMode = False
Next i

End Sub

お礼

すごい！今ちょっとカスタマイズして使ってみたところ、途中で止まることもなくうまく走りました！
でも、実は貼り付けたいシートにはグラフもついているのですが、グラフは貼り付けられませんでした・・・。
もしよろしかったら、グラフも一緒に貼り付けられる方法も教えて頂けるとありがたいのですが・・・。

回答No.2

papayuka

Excelのバージョンは何でしょう？
Excel97だと同一シートをコピーし続けた場合に、シートのオブジェクト名(CodeName）が「Sheet111111111・・・・」のようになってしまいコピー出来なくなるバグがあるのですが、、

こんな感じだとどうでしょう？
（試すならテストブックで）

貼り付け元ブックの全シートを貼り付け先ブックに書式を残して値コピーします。
セル結合があっても大丈夫だと思います。

Sub Test()
Dim cBook As Workbook, pBook As Workbook
Dim cWS As Worksheet, pWS As Worksheet

Set pBook = Workbooks("貼り付け先ブック.xls")
Set cBook = Workbooks("貼り付け元ブック.xls")

For Each cWS In cBook.Worksheets
　　Set pWS = pBook.Worksheets.Add _
　　　　(after:=pBook.Worksheets(pBook.Worksheets.Count))
　　cWS.Cells.Copy
　　pWS.Cells.PasteSpecial Paste:=xlPasteAll
　　pWS.Cells.Copy
　　pWS.Cells.PasteSpecial Paste:=xlValues
　　On Error Resume Next
　　pWS.Name = cWS.Name
　　Application.CutCopyMode = False
Next cWS

End Sub

お礼

回答ありがとうございます。
まだ試させていただいてはいないのですが、実は「貼り付け元ブック」にはシートが一つしかなく、それが一回「貼り付け先ブック」にコピーされると「貼り付け元ブック」のシートが書き換わり、その書き換わったシートを「貼り付け元ブック」にまたコピーしに行く、という作りなので、全シートをいっぺんに貼り付けに行く作りだと合わなくなるかな、と・・・。
ちなみにバージョンは２０００です。
せっかく教えていただいているのにすいません・・・。

回答No.1

eipu

現象はともかくとして、
シートをコピーするだけなら、

Sheets("貼り付け元シート").Activate
ActiveSheet.Copy After:=Workbooks("貼り付け先ブック.xls").Sheets("○○シート")
Windows("貼り付け元ブック.xls").Activate

の繰り返しで大丈夫だと思います。

お礼

早速の回答ありがとうございます。
実は、貼り付け元のシートは一回貼り付ける度に内容が変わるようになっているので、リンクを切る作りにしました。ただ、マクロが若干重たいのも一因かなとは思うのですが・・・。