エクセルのマクロについて教えてください。

Question

下記のマクロを実行すると画像のエラーメッセージが表示されマクロ「貼り付け」のコードの内「Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats」が黄色く表示されて上手くマクロを実行できません。
一連のマクロでは無く、手動で行うと上手く行きます。この問題を解決できる方法を教えてください。
何時もの作業の手順として、マクロ設定ブック：コピー先を開く（手動）次にコピー元のブックを開く（手動）次にコピー元のコピー範囲を指定（手動）次にコピー先のブックに貼り付け（マクロ：貼り付け）を実行次にコピー元のブックの削除（マクロ：電子提出削除）を日々行っており、この手順だとエラーが出ずにコピー元の指定範囲をコピー先の指定範囲にコピー出来、コピー元のファイルを削除できます。しかし、一連のマクロだとエラーメッセージが表示されます。
一連のマクロのままで上手くできる方法があるものですか？又、一連のマクロを一つのマクロとすると上手く行きますか？詳しく教えてください。よろしくお願いいたします。
一連のマクロ
Call 提出シートを開く
Call 提出シートコピー範囲
Call 貼り付け
Call 電子提出削除
End Sub
それぞれのマクロ
Sub 提出シートを開く()
On Error Resume Next
Dim folderPath As String
Dim fileName As String
folderPath = ThisWorkbook.Path & "\"
fileName = Dir(folderPath & "*(提出用).xlsx")
Do While fileName <> ""
Workbooks.Open (folderPath & fileName)
fileName = Dir()
Loop
End Sub
Sub 提出シートコピー範囲()
Dim Wb1, Wb2
Set Wb1 = Workbooks(1) 'このブック
Set Wb2 = Workbooks(2) '別ブック
'セルの値を取得する
Wb2.Worksheets("提出シート").Range("B1:H47").Copy
End Sub
Application.DisplayAlerts = False
Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.DisplayAlerts = True
End Sub
Sub 電子提出削除()
Dim wb As Workbook
For Each wb In Workbooks
With wb
If .Name Like "#########-#*" Then
If MsgBox(.Name & " を削除します", _
vbCritical + vbOKCancel, "警告！") = vbOK Then
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close (False)
Exit For
End If
End If
End With
Next
End Sub
以上となります。
日々この作業を多い時で数十回行います。以前も同じような質問をしておりますが、解決には至っておりません。是非、解決方法を教えてください。よろしくお願いいたします。

Qchan1962 · Accepted Answer

＃３で
Wb1.Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

と回答しているが・・・
Sub 貼り付け()
Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub
って何の話？

＞私としては、出来れば一連のマクロを実行でお願いしたいと考えております、その後に今回削除したコードをシート名「審査」にVBAコードとして設定したいと思います。

自身が処理手順を理解してVBAの初歩的な構造を理解すれば
作ってもらった３桁に達するであろうプロシージャの組み合わせでも容易だと思いますが・・・現状どうでしょうか私にはわかりません

Qchan1962 · Answer

長らく解決出来ないのは後から色々とご質問と違う所が出てくるところです

当該ご質問の部分を　まとめ　てみましたので　試してみてください

他に課題が生じた場合は別スレを立ててください

Sub 提出シートコピー削除2()
On Error Resume Next
Dim folderPath As String
Dim fileName As String
folderPath = ThisWorkbook.Path & "\"
fileName = Dir(folderPath & "*(提出用).xlsx")
If fileName <> "" Then
Workbooks.Open folderPath & fileName
Else
MsgBox "コピー元ファイルがありません", , "確認"
Exit Sub
End If

Dim Wb1 As Workbook, Wb2 As Workbook
Set Wb1 = Workbooks(1) 'このブック
Set Wb2 = Workbooks(2) '別ブック
'セルの値を取得する
Application.DisplayAlerts = False
Application.EnableEvents = False
Wb2.Worksheets("提出シート").Range("B1:H47").Copy
Wb1.Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
With Wb2
If .Name Like "#########-#*" Then
If MsgBox(.Name & " を削除します", _
vbCritical + vbOKCancel, "警告！") = vbOK Then
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close (False)
End If
End If
End With
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

Qchan1962 · Answer

ちなみにApplication.DisplayAlertsって・・・
これ外すと　どんなアラートが出るのですか？

Qchan1962 · Answer

なんか出てきたけれど・・・しかも省略
別問題だと思うので
貼り付け処理でイベントが発生しない様に貼り付け実行前の

Application.DisplayAlerts = False
の上もしくは下に
Application.EnableEvents = False
を追加

Application.DisplayAlerts = True
の上もしくは下に
Application.EnableEvents = True

ちなみにApplication.DisplayAlertsって・・・

Qchan1962 · Answer

サブルーチンで処理を分けている場合、他の処理でも流用している可能性を考えてしまいます

よく見たら　Sub 貼り付け()が抜けているだけで　たぶん書いてありましたね　
ならばWb1, Wb2をモジュールレベルにしてください　はする必要は無いですかね

Sub 提出シートコピー範囲()　と　Sub 貼り付け()

Sub 提出シートコピー範囲()
Dim Wb2 As Workbook
Set Wb2 = Workbooks(2) '別ブック
'セルの値を取得する
Wb2.Worksheets("提出シート").Range("B1:H47").Copy
End Sub

Sub 貼り付け()
Dim Wb1 As Workbook
Set Wb1 = Workbooks(1) 'このブック
Application.DisplayAlerts = False
Wb1.Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.DisplayAlerts = True
End Sub

サブルーチンがこの目的のみであるならまとめた方がよさげ
試していないので合っているか不明

Sub 提出シートコピー削除()
On Error Resume Next
Dim folderPath As String
Dim fileName As String
folderPath = ThisWorkbook.Path & "\"
fileName = Dir(folderPath & "*(提出用).xlsx")
If fileName <> "" Then
Workbooks.Open folderPath & fileName, ReadOnly:=True
Else
MsgBox "コピー元ファイルがありません", , "確認"
Exit Sub
End If

Dim Wb1 As Workbook, Wb2 As Workbook
Set Wb1 = Workbooks(1) 'このブック
Set Wb2 = Workbooks(2) '別ブック
'セルの値を取得する
Application.DisplayAlerts = False
Wb2.Worksheets("提出シート").Range("B1:H47").Copy _
Wb1.Worksheets("受付").Range("B1:H47").PasteSpecial(Paste:=xlPasteValuesAndNumberFormats)

With Wb2
If .Name Like "#########-#*" Then
If MsgBox(.Name & " を削除します", _
vbCritical + vbOKCancel, "警告！") = vbOK Then
Kill .FullName
.Close (False)
End If
End If
End With
Application.DisplayAlerts = True

End Sub

Qchan1962 · Answer

ご質問になかったけれど・・Sub 貼り付け()　後だしで追加されてもね
試しているわけではなく　コードを読んでるだけなのでね

Sub 貼り付け()ではなく
Sub 提出シートコピー範囲()　こっちの話

ちなみに　同じ処理が　Sub 提出シートコピー範囲()　にあるけれど
２度処理する意味がないと思うよ・・そちらはエラー大丈夫なの？

Call 提出シートを開く
Call 提出シートコピー範囲

Call 電子提出削除
End Sub

Sub 貼り付け()を処理しないで良くないですか・・

どうしても貼り付けを２度したいのなら

Sub 貼り付け()
Dim Wb1 As Workbook
Set Wb1 = ThisWorkbook
Application.DisplayAlerts = False
Wb1.Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.DisplayAlerts = True
End Sub

もしくは
Dim Wb1, Wb2　をモジュールレベルにしてください
って・・・意味わかりますか？

Qchan1962 · Answer

手動で行うとうまくいく　VBAだとダメ・・・
おそらく　ブック指定がされていないため
（手動だとアクティブにするからOK）
Wb2にWorksheets("受付")シートが無いのだと思いますので

Wb1.Worksheets("受付").Range("B1:H47").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

として試してみて

エクセルのマクロについて教えてください。

＃３で

長らく解決出来ないのは後から色々とご質問と違う所が出てくるところです

ちなみにApplication.DisplayAlertsって・・・

なんか出てきたけれど・・・しかも省略

サブルーチンで処理を分けている場合、他の処理でも流用している可能性を考えてしまいます

ご質問になかったけれど・・Sub 貼り付け() 後だしで追加されてもね

手動で行うとうまくいく VBAだとダメ・・・

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

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

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

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

ご質問になかったけれど・・Sub 貼り付け()　後だしで追加されてもね

手動で行うとうまくいく　VBAだとダメ・・・