Excelvbaで同一フォルダー内のブックの一番左のシートをコピーしたいです。

Excelvbaで下記動作をさせたいです。
①「作成」というブック名のExcelファイル（
xlsx）があります。作成のExcelファイルは原紙というシートのみあります。それと同一フォルダー内に適当な名前が付いたExcelファイル（xlsx）がいくつかあります。
②作成を開きマクロを実行すると、適当な名前が付いたExcelファイルの一番左側のシートが作成のExcelファイルへ移動します。移動した後のシート名は1、2、3、4、5、6・・・と連番とします。シート構成は、原紙、1・2・3というようになります。

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

• ①「適当な名前が付いたExcelファイル（xlsx）」の張付け順番は気にしないで同じフォルダの物を全て張付ければ良いという事でしょうか？
  
  →同じフォルダー内のExcelファイル全てで順番は気にしません。※作成Excelファイルに移動するファイルは一番左のみでお願いします。
  ② マクロを書き込んでいるExcelファイル（xlsm）ファイルも同じフォルダに有るという事で良いのでしょうか？
  
  →xlsmも同じフォルダー内にあります。

    補足日時：2020/01/14 21:06

• マクロを書き込んでいるExcelファイル（xlsm）と同じフォルダーにxlsmとxlsxが二種類あった場合も同じ動作が行くようにできますか。

    補足日時：2020/01/15 12:19

No.1 回答者： GooUserラック 回答日時： 2020/01/14 20:57

①「適当な名前が付いたExcelファイル（xlsx）」の張付け順番は気にしないで同じフォルダの物を全て張付ければ良いという事でしょうか？

② マクロを書き込んでいるExcelファイル（xlsm）ファイルも同じフォルダに有るという事で良いのでしょうか？

No.2 ベストアンサー 回答者： tom04 回答日時： 2020/01/14 21:23

こんばんは！

一例です。
「作成」ブックの標準モジュールにしてください。

Sub Sample1()
　Dim myPath As String, fN As String
　Dim cnt As Long
　Dim wB As Workbook, wS As Worksheet
　　myPath = ThisWorkbook.Path & "\"
　　fN = Dir(myPath & "*.xlsx")

　　Application.ScreenUpdating = False
　　　Do Until fN = ""
　　　　Workbooks.Open (myPath & fN)
　　　　　Set wB = ActiveWorkbook
　　　　　cnt = cnt + 1
　　　　　With ThisWorkbook
　　　　　　.Worksheets.Add after:=Worksheets(cnt)
　　　　　　Set wS = .Worksheets(cnt + 1)
　　　　　　　wS.Name = cnt
　　　　　　　wB.Worksheets(1).Cells.Copy wS.Range("A1")
　　　　　　　　Application.DisplayAlerts = False
　　　　　　　　　wB.Close
　　　　　　　　Application.DisplayAlerts = True
　　　　　　　fN = Dir()
　　　　　End With
　　　Loop
　　Application.ScreenUpdating = True
　　　MsgBox "完了"
End Sub

※　未検証なので、不具合が出たらごめんなさい。m(_ _)m

No.3 回答者： GooUserラック 回答日時： 2020/01/14 23:29

以下のような物はいかがでしょうか？

※「作成.xlsx」が閉じている状態で実行して下さい。
※ 適当な名前の、Excelファイル（xlsm）に書き込んで実行して下さい。

Sub Sample()

Const 作成ファイル名 As String = "作成.xlsx"
Dim パス名 As String
Dim シート番号 As Long
Dim ファイル名 As String
Dim 処理済 As Boolean

　パス名 = ThisWorkbook.Path & "\"
　Workbooks.Open Filename:=パス名 & 作成ファイル名
　Application.DisplayAlerts = False
　Do Until Workbooks(作成ファイル名).Sheets.Count = 1
　　Sheets(2).Delete
　Loop
　Application.DisplayAlerts = True
　ファイル名 = Dir(パス名 & "*.xlsx")
　Do While ファイル名 <> ""
　　If ファイル名 <> 作成ファイル名 Then
　　　Workbooks.Open Filename:=パス名 & ファイル名
　　　シート番号 = シート番号 + 1
　　　Sheets(1).Copy After:=Workbooks(作成ファイル名).Sheets(シート番号)
　　　ActiveSheet.Name = シート番号
　　　Windows(ファイル名).Close
　　　ファイル名 = Dir()
　　Else
　　　If 処理済 Then
　　　　Exit Sub
　　　Else
　　　　処理済 = True
　　　End If
　　End If
　Loop

End Sub