詳しい人求む！

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

解決済

質問者：エクセル小僧
質問日時：2024/09/12 10:09
回答数：1件

下記のマクロを実行すると
コピー元のシートの指定セル範囲を、コピー元（マクロ設定ブック）にコピーできます。
コピー元のシートが「Table 1」「Table 2」「Table 3」が3つあり
シートを「Table 2」と指定しているのですが、上手くコピペできません、
コピー元のシート「Table 1」と「Table 3」をあらかじめ削除し、「Table 2」のみの状態で、マクロを実行すると、上手く行きます。
出来ればコピー元のシートが「Table 1」「Table 2」「Table 3」3つある状態で上手くコピペ出来る方法を教えてください。
現状のマクロです。
Sub Macro1()
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
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
以上となります。
よろしくお願いいたします。