VBA シートをコピーする際に Copyメソッドは失敗しましたのエラーが出てしまいます

Question

VBAにてシートをコピーしようとした際に、'Copy'メソッドは失敗しました ’Sheets'オブジェクト
というエラーが発生してしまいます。
処理としては、画像と文章の混じったブックにて、Sheet1とSheet2をコピーし、そのコピー先のブックにて印刷設定や書式設定等の整地を行いセルの値から取得した名前で保存
そのご、元ブックにて保存した勤務によって次の勤務や日付を記入する
という処理です。
下記コードです。
よろしくお願い致します。

Sub 連絡帳保存()
Dim sDate
Dim sLast
Dim sLastday
sDate = Sheets(1).Range("B2").Value
sLast = DateSerial(Year(sDate), Month(sDate) + 1, 0)
sLastm = Format(sLast, "m")
sLastday = Format(sLast, "d")
Dim d As String
d = Sheets("Sheet1").Range("B2")
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim m As Long
Dim n As Range
Dim j As Long
Dim k As Range
Dim E As String
    E = "\SEIZO\seizo\★連絡帳\連絡帳Excel"　& Format(d, "yyyy""年""m""月""d""日"";@") & "～" & Format(d, "yyyy""年""m""月" & sLastday & "日"";@") & ".xlsx"
Dim Ename As String
    Ename = Format(d, "yyyy""年""m""月""d""日"";@") & "～" & Format(d, "yyyy""年""m""月" & sLastday & "日"";@") & ".xlsx"
Dim P As String
    P = "\SEIZO\seizo\★連絡帳\連絡帳PDF"　& Format(d, "yyyy""年""m""月""d""日"";@") & "～" & Format(d, "yyyy""年""m""月" & sLastday & "日"";@") & ".pdf"
Dim r As Long
Dim today As String
today = Date
Dim half As String
half = Format(d, "yyyy""/""mm""/""15")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Shapes.SelectAll
Selection.Placement = xlMoveAndSize
Range("A1").Activate

Worksheets(Array(1, 2)).Copy ←デバックで確認するとここでエラーが出ます

Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
With S1
.Buttons.Delete
.Columns(10).WrapText = True
.Cells.EntireRow.AutoFit
.Range("B:J").ColumnWidth = 10
r = Cells(Rows.Count, "B").End(xlUp).Row
a = r
.PageSetup.PrintArea = Range(.Cells(1, 1), .Cells(a, 9)).Address
End With
With S1.PageSetup
 .Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
S1.Activate
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.Zoom = 100
S2.Activate
With S2
.Buttons.Delete
.Columns(10).WrapText = True
.Cells.EntireRow.AutoFit '行の高さを調整
.Range("B:J").ColumnWidth = 10  'A～Iの列幅を10へ変更
r = Cells(Rows.Count, "B").End(xlUp).Row
a = r
.PageSetup.PrintArea = Range(.Cells(1, 1), .Cells(a, 9)).Address
End With
With S2.PageSetup
.Orientation = xlPortrait
.Zoom = False 
.FitToPagesWide = 1
.FitToPagesTall = False
End With
S1.Activate
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.Zoom = 100
Range("B" & r).Activate
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=E
Worksheets(Array("Sheet1", "Sheet2")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=P
ActiveWorkbook.Close
Application.DisplayAlerts = True
Set S1 = Nothing
Set S2 = Nothing
Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
For j = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
Set k = Range("C2:C320").Find("勤", lookAt:=xlPart)
If ActiveSheet.Name = "Sheet1" And Application.WorksheetFunction.CountIf(ActiveSheet.Range("B2:B320"), half) > 0 And Cells(j, 3).Value = "丙勤" _
Or ActiveSheet.Name = "Sheet1" And Day(Date) > 15 Then
S2.Activate
r = Cells(Rows.Count, "B").End(xlUp).Row
With S2
.Range("B2:I2").UnMerge
.Range("B2").Value = DateAdd("d", 0, today)
.Range("C2").Value = "甲勤"
.Range("D" & r).Select
End With
Exit For
Else
r = Cells(Rows.Count, "B").End(xlUp).Row
If k Is Nothing Then
MsgBox ("勤務が見つかりません")
Exit For
 Else
If Cells(j, 3).Value = "甲勤" Then
With Range("B" & (r + 1))
.UnMerge
.Value = Cells(j, 2).Value
.HorizontalAlignment = xlHAlignLeft
.Font.Name = "Arial"
End With
Range("C" & (r + 1)).Value = "乙勤"
Exit For
End If   
If Cells(j, 3).Value = "乙勤" Then
With Range("B" & (r + 1))
.UnMerge
.Value = Cells(j, 2).Value
.HorizontalAlignment = xlHAlignLeft
.Font.Name = "Arial"
End With
Range("C" & (r + 1)).Value = "丙勤"
Exit For
End If
If Cells(j, 3).Value = "丙勤" Then
With Range("B" & (r + 1))
.UnMerge
.Value = Cells(j, 2).Value + 1
.HorizontalAlignment = xlHAlignLeft
.Font.Name = "Arial"
End With
Range("C" & r + 1).Value = "甲勤"
Exit For
End If
End If
End If
Next j
ActiveWorkbook.Save
Range("D" & r).Activate
Application.ScreenUpdating = True
End Sub

Qchan1962 · Accepted Answer

＃５です
シート全体でなく範囲を新規ブックにコピーする　方法ではどのようになりますか　と言う事かな

Sub test1()
    Dim n As Integer
    Dim myBk As Workbook
    Dim newBk As Workbook

Set myBk = ActiveWorkbook
    n = Application.SheetsInNewWorkbook　’シート数　デフォルト値
    Application.SheetsInNewWorkbook = 2

Set newBk = Workbooks.Add　’新規ブックを作成（2シート）
    Application.SheetsInNewWorkbook = n
    For n = 1 To 2
        myBk.Worksheets(n).UsedRange.Copy newBk.Worksheets(n).Cells(1, 1)
    Next
End Sub

*注意　範囲を限定してメモリー消費を小さくしていますが
UsedRange　上に　シェイプが入っていないとシェイプはコピーされません。

Qchan1962 · Answer

＃３の補足について
この内容を読むと＃４mygoonickname　様が案内されている記事が
参考になると思われます。
以前読んだことのある記事なので　古いですが信頼性はあります。
（忘れていましたが、自身も躓いた経験がありました）
代替え、対策も掲示されています。

＞ActiveWorkbook.SaveAs Filename:=Eのフォーマットとはどういった意味でしょうか。
あ、マクロ付きブックが作成され & ".xlsx"で保存するので
保存は通常ブックですよ　指定をした方が良いかなと思いました。
参考：
https://docs.microsoft.com/ja-jp/office/vba/api/excel.workbook.saveas
https://docs.microsoft.com/ja-jp/office/vba/api/excel.xlfileformat
xlWorkbookDefault	51	ブックの既定	*.xlsx

お節介ついでで、複数のブックを扱う場合、ブックを明示（set　や　With)をすると読解性が良くなり改修もやりやすくなるのでは、、

mygoonickname · Answer

こんにちは。

参考になるか分かりませんが、検索した記事になります。
エクセルVBA　cells.copyでシート全体コピーを行うと、「Copyメソッドは失敗した」と出て、エクセルがフリーズする

https://answers.microsoft.com/ja-jp/msoffice/forum/all/%E3%82%A8%E3%82%AF%E3%82%BB%E3%83%ABvba/153c12e7-7563-4513-905e-de3d293ce873

Qchan1962 · Answer

＃２です　そうですよね。
私ならどうするか、、
問題解決になるかはわかりませんが
シンプルなコード（プロシージャ）を作成して実行してみる。
新規ブックで２シートを作成し図形を一応入れる
標準モジュールで
Sub test()
Worksheets(Array(1, 2)).Copy
End Sub
Worksheetインデックス1と２のシートがコピーされた
新しいブックが出来るはず・・・

エラーが発生したら・・・Officeの修復やアップデートを実行
問題が無ければ、エラーが出るブックの同じモジュールでテスト
エラーが出れば、モジュールを新しく挿入して、、試す

該当ブックのみエラーが出る場合、破損している可能性があると思いますので修復を試みても改善されない場合は、新規ブックに内容すべてを移す
などを実施するかな・・・

あと、流し読みで違っていたら忘れてほしいのですが
ActiveWorkbook.SaveAs Filename:=E
フォーマットも設定しておいた方が良いかも、
Application.DisplayAlerts = False　だからまあ、いいのかな。

Qchan1962 · Answer

こんにちは
＞Worksheets(Array(1, 2)).Copy ←デバックで確認するとここでエラーが出ます
Worksheets(Array(1, 2)).Copy
この行まで実行されたのなら、これに、エラー要素があると思えないのですが・・
エラーが出ないので
sDate = Sheets(1).Range("B2").Value　Sheets(1)にはB2セルがある　グラフシートなどではない

ActiveSheet.Shapes.SelectAll　下記と合わせ、選択できるので保護はない
Selection.Placement = xlMoveAndSize　シェイプはある。選択したオブジェクトをセルと共に移動かつセルに合わせてサイズ変更を許可

その他、上のコードは文字列作成なので上部では不問・・・
やっぱりエラー要素思いつかないのですけれど

SheetsとWorksheetsが混在しグラフページなどがあるのかな？
sDate = Sheets(1).Range("B2").Value
d = Sheets("Sheet1").Range("B2")
インデックス1はSheets("Sheet1")ではないのかな？

回答とは関係ないのですが、此のあたりの書き方やSetの位置など再考してまとめてみては

mygoonickname · Answer

おはようございます。

マクロの記録で取った、2つのシートのコピーですと、下記の様になります。
シート名は文字列で入れて、""で囲んでみてはダメでしょうか？

(例)　Sheets(Array("Sheet1", "Sheet2")).Copy

VBA シートをコピーする際に Copyメソッドは失敗しましたのエラーが出てしまいます

＃５です

＃３の補足について

こんにちは。

＃２です そうですよね。

こんにちは

おはようございます。

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

このQ&Aを見た人はこんなQ&Aも見ています

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

このQ&Aを見た人がよく見るQ&A

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

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

＃２です　そうですよね。