プロが教える店舗&オフィスのセキュリティ対策術

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

質問者からの補足コメント

  • ご回答ありがとうございます。
    当方も初期のコードではそのように記述しておりましたが、シート名を変更される懸念よりシートの順番にて指定しています。
    再度、シート名指定にて実行してみましたがエラーが発生してしまいました。
    また、~.Copyがダメなのかとも考え、保存用ブックというブックを作成し、そこへコピーする
    .Copy after:=~も試しましたが、こちらはオブジェクトがクライアントから切断されましたといった旨のエラーが発生しました。

    No.1の回答に寄せられた補足コメントです。 補足日時:2022/01/27 10:10
  • ご回答ありがとうございます。
    そうなのです。私自身、エラー要素がないと考えておりますが、実際実行するとCopyメソッドの失敗により止まってしまっているので、頭を抱えております。
    仰る通り、インデックス1はSheets("Sheet1")です。統一致します。
    また、グラフページはなく、Sheet1に1~15日分、Sheet2 に16日~31日分を記載した画像と文章のみです。
    エラーで止まった後、ファイル名"Excel"というファイルが立ち上がってフリーズしており、それを閉じるとbook1が破損を回復したファイルとして開かれます。そのbook1にはコピー自体はされておりますので、Setの位置は問題ないのではと思っております。

    No.2の回答に寄せられた補足コメントです。 補足日時:2022/01/27 11:18
  • うーん・・・

    新規ブックの件ですが、実は本マクロは内容が異なる3つファイルにて使用しているのですが、そのうち2つで本エラーが発生しています。残りの1つでは使用者に確認したところこのようなエラーの発生は一度もないとのことでした。
    これらのファイルサイズが約180KB,約2.5MB、約3.5MBで、180KBのファイルでのみエラーなしです。そのため、ファイルが重いことによるものなのかと頭をよぎったのですが、今5MBほどの新規ブックにてWorkSheets(Array(1,2)).Copyは出来ました。
    エラーが出ればモジュールを新しく、、というのは該当ブックに標準モジュールを新たに挿入し、そこへ記述し実行ということでしょうか。
    また、最後の一分のActiveWorkbook.SaveAs Filename:=Eのフォーマットとはどういった意味でしょうか。

    No.3の回答に寄せられた補足コメントです。 補足日時:2022/01/27 12:29
  • こんにちは。
    ご回答ありがとうございます。
    URL先の記事一読いたしましたが、私のコードでは.Copyですので、コピー先のシートというものは何になるんでしょうか。book1でしょうか。しかし、book1が作成されたときには元のブックのシート内容がコピーされているので、削除はよろしくありません。
    ただ、KB2956081やシートのコピー後に1セルのみコピーを参考にさせていただこうと思います。
    1セルのみのコピーはCopyメソッドでエラーが出るため現実的ではないですが、作業を分けるといった方向性で検討してみます。

    No.4の回答に寄せられた補足コメントです。 補足日時:2022/01/27 12:33
  • 本日、他の業務で忙しくしっかりと読めていないので、時間ができ次第じっくり読もうと思います。
    .xlsxの通常ブックでの保存で問題ありません。むしろ通常ブックでの保存を狙っています。そのためシート上のマクロボタンを削除するコードを組み込んでいます。
    この一行を省いて、マクロボタン等のマクロ関係はコピーせずその他はコピーするなんて言う便利なコードはあるのでしょうか。

    ある程度は明示できているつもりですが、明治のない部分はブックの明示も時間ができ次第、少しずつ進めていこうと思います。

    提示いただいたUsedRangeを試したところ、エラーは発生しませんでしたが、質問のマクロもなぜかエラーなく進みました。。
    なので、質問のマクロにてエラーが発生した時にUsedRangeにてコピーを試してみようと思います。
    確かにメモリー消費が大きいことも原因にあるのではと考えております。

    No.5の回答に寄せられた補足コメントです。 補足日時:2022/01/27 17:00

A 回答 (6件)

#5です


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

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 上に シェイプが入っていないとシェイプはコピーされません。
    • good
    • 0

#3の補足について


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

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

お節介ついでで、複数のブックを扱う場合、ブックを明示(set や With)をすると読解性が良くなり改修もやりやすくなるのでは、、
この回答への補足あり
    • good
    • 0

こんにちは。



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

https://answers.microsoft.com/ja-jp/msoffice/for …
この回答への補足あり
    • good
    • 0

#2です そうですよね。


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

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

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

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

こんにちは


>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の位置など再考してまとめてみては
この回答への補足あり
    • good
    • 0

おはようございます。



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

(例) Sheets(Array("Sheet1", "Sheet2")).Copy
この回答への補足あり
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

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


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

人気Q&Aランキング