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

下記のマクロは先ほど教えて頂いたマクロで
コピー元の指定シートとセル値をコピー先にコピペできます。
Sub Macro1()
Call 採光シートコピー範囲
Call 貼り付け
Call 採光データ削除
End Sub
張り付けた後に
コピー元のファイルが不要の為、マクロ「採光データ削除」を実行して、ファイルを削除したいのですが、削除対象のファイルが開いた状態なので、エラーメッセージが出て、ファイルを削除できません。
以前教えて頂いたコードをそのまま利用しており、コピー元のファイルのコピー範囲が完了するとこのファイルは閉じると思うのですが、なぜか、開いたままの状態です。
それぞれのマクロを書き込みますので、解決方法を教えてください。
Sub 採光シートコピー範囲()
Dim folderPath As String
Dim fileName As String
Dim ws As Worksheet
folderPath = ThisWorkbook.Path & "\"
'作業フォルダ内にはマクロを設定しているコピー先のブックとコピー元の
' 採光計算確認.xlsxの 2つ のExcelファイルしかありません｡
fileName = Dir(folderPath & "*.xlsx?")
Do While fileName <> ""
If CheckName(fileName) = True Then Exit Do
fileName = Dir()
Loop
If fileName <> "" Then
'別ブック 採光計算書.xlsx
Set Wb2 = Workbooks.Open(folderPath & fileName)
On Error Resume Next
Set ws = Wb2.Worksheets("Table 2")
If Err.Number <> 0 Then
MsgBox "コピー元ブックの提出シートが見つかりません"
On Error GoTo 0
Wb2.Close False
End
End If
'セルの値を取得する
ws.Range("A1:W51").Copy
On Error GoTo 0
ws.Activate
ws.Range("A1:W51").Copy
Else
MsgBox "コピー元ブックが見つかりません": End
End If
End Sub
Private Function CheckName(ByVal fileName As String) As Boolean
CheckName = False
If fileName = ThisWorkbook.Name Then Exit Function
CheckName = True
If LCase(Right(fileName, 5)) = ".xlsx" Then Exit Function
If LCase(Right(fileName, 5)) = ".xlsm" Then Exit Function
CheckName = False
End Function
Sub 貼り付け()
Dim ws1 As Worksheet
Set Wb1 = Workbooks(1) 'このブック
On Error Resume Next
Set ws1 = Wb1.Worksheets("採光確認")
If Err.Number <> 0 Then
MsgBox "コピー先ブックの受付シートが見つかりません"
Application.CutCopyMode = False
On Error GoTo 0
If Not Wb2 Is Nothing Then Wb2.Close False
End
End If

Application.DisplayAlerts = False
Application.EnableEvents = False
ws1.Range("A1:W52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Sub 採光データ削除()

Dim filePath As String
filePath = ThisWorkbook.Path & "\採光計算書.xlsx"

If Dir(filePath) <> "" Then
Kill filePath
End If
End Sub
以上となります。
よろしくお願いいたします。

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

• 

  １．コピー元／コピー先のブック名、シート名、セル位置の確認です。
  下記であってますか。
  コピー元のブック名：採光計算書.xlsx
  コピー元のシート名：Table 2
  コピー元セル：A1:W51
  以上全てあっております。
  コピー先のブック名：採光計算確認.xlsm
  コピー先のシート名：採光確認
  コピー先のセル：A1:W51　が正しいです。
  
  ２．コピー元のブック、コピー先のブックは、マクロのあるブックと同じフォルダに格納されている前提で良いですか。
  はい、同じフォルダ内に格納されております。
  コピー元及びコピー先のファイル名は固定です。
  よろしくお願いいたします。

    補足日時：2024/09/12 13:01

• ご親切にありがとうございます。
  教えて頂いたコードを全て設定し、
  マクロを実行しましたが、画像のエラーが出てしまい、実行できませんでした、
  何度も申し訳ありません。
  よろしくお願いいたします。

  
  No.5の回答に寄せられた補足コメントです。 補足日時：2024/09/12 13:53

• 

  補足要求です。
  １．コピー元／コピー先のブック名、シート名、セル位置の確認です。
  下記であってますか。
  コピー元のブック名：採光計算書.xlsx
  コピー元のシート名：Table 2
  コピー元セル：A1:W51
  はい、以上で全てあっております。
  
  コピー先のブック名：採光計算確認.xlsm　になります。
  コピー先のシート名：採光確認
  コピー先のセル：A1:W51　で間違いでした。
  コピー元及びコピー先のファイル名は固定です。
  よろしくお願いいたします。

  No.3の回答に寄せられた補足コメントです。 補足日時：2024/09/12 14:18

• 

  先ほど補足をさせて頂きましたが
  提示されたマクロを格納しているのは、
  ①採光計算確認.xlsm　です。
  よろしくお願いいたします。

  No.4の回答に寄せられた補足コメントです。 補足日時：2024/09/12 14:23

• 

  何時も助けて頂きましてありがとうございます。
  全て上手くできました。感謝、感謝です。

  No.6の回答に寄せられた補足コメントです。 補足日時：2024/09/13 08:20

No.6 ベストアンサー 回答者： Qchan1962 回答日時： 2024/09/12 18:52

たぶんうまく動かないからレスが無いのかなと・・

閲覧があまりできないので
１つにまとめ簡単にデバッグしたコードです
試してみてください

あくまで素人の個人的意見ですがプロシージャを分けるのも良いけれど
繰り返し使う事もなくあまり複雑でもないし　サブで定数（決まった値）を使っているのであれば、あまり意味ないと思いますよ
と　この回答もあまり意味はありませんね

Sub Macro1()
Dim Wb1 As Workbook, Wb2 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim folderPath As String
Dim fileName As String

Const destination_sheet As String = "採光確認"
Const source_book As String = "採光計算書.xlsx"
Const source_sheet As String = "Table 2"

Set Wb1 = ActiveWorkbook
Set ws1 = objSht(Wb1, destination_sheet)
If ws1 Is Nothing Then
MsgBox "コピー先ブック:" & Wb1.Name & "の" & destination_sheet & "シートが見つかりません"
Exit Sub
End If

folderPath = ThisWorkbook.Path

fileName = Dir(folderPath & "\" & source_book)
If fileName <> "" Then
Application.ScreenUpdating = False
Set Wb2 = Workbooks.Open(folderPath & "\" & fileName)
Set ws = objSht(Wb2, source_sheet)
If ws Is Nothing Then
MsgBox "コピー元ブック:" & source_book & "の" & source_sheet & "シートが見つかりません"
Wb2.Close False
Set Wb2 = Nothing
Application.ScreenUpdating = True
End
End If
Else
MsgBox "コピー元ブック:" & source_book & "が見つかりません": End
End If
Application.DisplayAlerts = False
Application.EnableEvents = False
'セルの値を取得する
ws.Activate
ws.Range("A1:W51").Copy
ws1.Range("A1:W51").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
If Not Wb2 Is Nothing Then Wb2.Close False
Application.CutCopyMode = False

Kill fileName

Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Private Function objSht(bk As Workbook, sName As String) As Object
Dim obj As Object
On Error Resume Next
Set obj = bk.Worksheets(sName)
On Error GoTo 0
Set objSht = obj
End Function

＃５は適当にコピペしただけなので　忘れてください

この回答へのお礼

ご連絡ありがとうございました
早速試させて頂きます
又、後ほど、結果をご連絡させて頂きます

お礼日時：2024/09/12 19:28

No.5 回答者： Qchan1962 回答日時： 2024/09/12 13:16

あれ？閉じてないから削除できないではなかったかのかな

書き直してほしいわけ？

Option Explicit

Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet

Sub Macro1()
Set Wb1 = ActiveWorkbook
On Error Resume Next
Set ws1 = objSht(Wb1, "採光確認")
If ws1 Is Nothing Then
MsgBox "コピー先ブックの受付シートが見つかりません"
Exit Sub
End If
Call 採光シートコピー範囲
Call 貼り付け
Call 採光データ削除
End Sub

Sub 採光シートコピー範囲()
Dim folderPath As String
Dim fileName As String
Dim ws As Worksheet
folderPath = ThisWorkbook.Path & "\採光計算確認.xlsx"
fileName = Dir(folderPath)
If fileName <> "" Then
Set Wb2 = Workbooks.Open(folderPath & fileName)
Set ws = objSht(Wb2, "Table 2")
If ws Is Nothing Then
MsgBox "コピー元ブックの提出シートが見つかりません"
Wb2.Close False
Set Wb2 = Nothing
End
End If
'セルの値を取得する
ws.Activate
ws.Range("A1:W51").Copy
Else
MsgBox "コピー元ブックが見つかりません": End
End If
End Sub

Private Function objSht(bk As Workbook, sName As String) As Object
Dim obj As Object
Set obj = bk.Worksheets(sName)
Set objSht = obj
End Function

Sub 貼り付け()
Application.DisplayAlerts = False
Application.EnableEvents = False
ws1.Range("A1:W52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
If Not Wb2 Is Nothing Then Wb2.Close False
Set Wb2 = Nothing
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Sub 採光データ削除()
Dim bk As Workbook
Dim filePath As String
filePath = ThisWorkbook.Path & "\採光計算書.xlsx"
'念のため
For Each bk In Workbooks
If bk.FullName = filePath Then
bk.Close False
Exit For
End If
Next
If Dir(filePath) <> "" Then
Kill filePath
End If
End Sub

分ける必要性を感じないけれど　必要なのかもしれないから
分けています
Sub 採光データ削除()は単独でも実行可能なようにしています

No.4 回答者： tatsumaru77 回答日時： 2024/09/12 13:06

提示されたマクロを格納しているのは、

①採光計算確認.xlsm　でしょうか。
②採光計算確認.xlsm以外のブック
のどちらでしょうか。
私は②であると判断して、補足要求を行いましたが、
①でしょうか。

No.3 回答者： tatsumaru77 回答日時： 2024/09/12 12:55

補足要求です。

１．コピー元／コピー先のブック名、シート名、セル位置の確認です。
下記であってますか。

コピー元のブック名：採光計算書.xlsx
コピー元のシート名：Table 2
コピー元セル：A1:W51

コピー先のブック名：不明
コピー先のシート名：採光確認
コピー先のセル：A1:W52

①コピー先のブック名が不明です。拡張子も含めて正しく、提示してください。
②コピー先のセル範囲は、A1:W51が正しいと思いますが、いかがでしょうか。（A1:W52は誤り）


２．コピー元のブック、コピー先のブックは、マクロのあるブックと同じフォルダに格納されている前提で良いですか。

３．現行のマクロをみると、マクロ実行時
コピー元のブックはクローズしている。（マクロがオープン）
コピー先のブックはオープンされている。（マクロはオープンしない）
となっていますが、それが望まれる仕様でしょうか。
コピー先のブックもクローズされている状態で、マクロを起動し、マクロがコピー先のブックを
オープンするようにすることも可能です。

４．コピー元のブックをオープンする時、ワイルドカード指定(*.xlsx?)
でファイル名を取得していますが、今回は、ファイル名が、"採光計算書.xlsx"
と決定しているので、直接そのファイルをオープンしたほうが良さそうです。
ワイルドカード指定にこだわる理由がなければ、直接ファイル名を指定してオープン
するようにしたいのですが、いかがでしょうか。

No.2 回答者： Qchan1962 回答日時： 2024/09/12 12:31

Wb2の宣言はモジュールレベルなのかな？

使いまわししているカモで
If Not Wb2 Is Nothing Then Wb2.Close False
下に一応加えた方が良いかも・・
Set Wb2 = Nothing

No.1 回答者： Qchan1962 回答日時： 2024/09/12 12:26

示されているコードについては突っ込みどころ満載ですが・・

対応策だけ・・・
＞削除対象のファイルが開いた状態なので
原因が分かっているのなら・・処理レスポンスは置いときますが閉じればよいのでは？
コピペでの回答

ws1.Range("A1:W52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
If Not Wb2 Is Nothing Then Wb2.Close False