Sub Test() '批量讀取

Dim i As Integer, iRow As Integer, iRow2 As Integer
Dim strPath, Filename, Search_Fullname As String
Dim TheSheet, TheSheet2, CurrentSheet, CurrentSheet2 As Worksheet
Dim Coll_Docs As New Collection
Dim activeSheetName As String
Dim activeSheetName2 As String
iRow = 1
iRow2 = 1
Set TheSheet = ActiveWorkbook.Worksheets("新表格(直接貼上)") '拷貝到的檔案工作表
Set TheSheet2 = ActiveWorkbook.Worksheets("新表格(直接貼上) (2)") '拷貝到的檔案工作表
strPath = "C:\Users\Joe_Hsu\Desktop\成品檢驗紀錄表_檢驗完成" '拷貝來源資料路徑
Filename = "*.xlsx" '選取之副檔名
Set Coll_Docs = Nothing

DocName = Dir(strPath & "/" & Filename)

Do Until DocName = ""
    Coll_Docs.Add Item:=DocName
    DocName = Dir
Loop

        For i = Coll_Docs.Count To 1 Step -1
            Search_Fullname = strPath & "/" & Coll_Docs(i)
            Workbooks.Open (Search_Fullname)
            activeSheetName = "Mechanical inspection report" '順序排列的第n個工作表名稱
            Set CurrentSheet = ActiveWorkbook.Worksheets(activeSheetName)
                CurrentSheet.Activate
                CurrentSheet.UsedRange.Copy
                TheSheet.Activate
                'While TheSheet.range("A" & iRow).Value <> ""
                '    TheSheet.Cells(iRow, 1) = iRow
                '    iRow = iRow + 1
                'Wend

                TheSheet.range("A" & iRow).Select
                ActiveSheet.Paste
                ActiveWorkbook.Save
            activeSheetName2 = "Phot" '順序排列的第n個工作表名稱
            Set CurrentSheet2 = ActiveWorkbook.Worksheets(activeSheetName2)
                CurrentSheet2.Activate
                CurrentSheet2.UsedRange.Copy
                TheSheet2.Activate
                While TheSheet2.range("A" & iRow2).Value <> ""
                    TheSheet2.Cells(iRow2, 1) = iRow2
                    iRow2 = iRow2 + 1
                Wend

                TheSheet2.range("A" & iRow2).Select
                'Sheets(activeSheetName2).Select
                'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
                ActiveSheet.Paste
                ActiveWorkbook.Save

            Workbooks(Workbooks.Count).Close
            總成轉換_直接貼上 '每一個檔案貼上後需執行的動作模組
        Next i

End Sub
-----------------------------------------------------------------------------------------------
去除其中一個項目後
Sub Test() '批量讀取

Dim i As Integer, iRow As Integer, iRow2 As Integer
Dim strPath, Filename, Search_Fullname As String
Dim TheSheet, TheSheet2, CurrentSheet, CurrentSheet2 As Worksheet
Dim Coll_Docs As New Collection
Dim activeSheetName As String
Dim activeSheetName2 As String
iRow = 1
iRow2 = 1
Set TheSheet = ActiveWorkbook.Worksheets("新表格(直接貼上)") '拷貝到的檔案工作表
Set TheSheet2 = ActiveWorkbook.Worksheets("新表格(直接貼上) (2)") '拷貝到的檔案工作表
strPath = "C:\Users\Joe_Hsu\Desktop\成品檢驗紀錄表_檢驗完成" '拷貝來源資料路徑
Filename = "*.xlsx" '選取之副檔名
Set Coll_Docs = Nothing

DocName = Dir(strPath & "/" & Filename)

Do Until DocName = ""
    Coll_Docs.Add Item:=DocName
    DocName = Dir
Loop

        For i = Coll_Docs.Count To 1 Step -1
            Search_Fullname = strPath & "/" & Coll_Docs(i)
            Workbooks.Open (Search_Fullname)
            activeSheetName = "Mechanical inspection report" '順序排列的第n個工作表名稱
            Set CurrentSheet = ActiveWorkbook.Worksheets(activeSheetName)
                CurrentSheet.Activate
                CurrentSheet.UsedRange.Copy
                TheSheet.Activate
                'While TheSheet.range("A" & iRow).Value <> ""
                '    TheSheet.Cells(iRow, 1) = iRow
                '    iRow = iRow + 1
                'Wend

                TheSheet.range("A" & iRow).Select
                ActiveSheet.Paste
                ActiveWorkbook.Save
            activeSheetName2 = "Phot" '順序排列的第n個工作表名稱
            Set CurrentSheet2 = ActiveWorkbook.Worksheets(activeSheetName2)
                CurrentSheet2.Activate
                CurrentSheet2.UsedRange.Copy
                TheSheet2.Activate
                While TheSheet2.range("A" & iRow2).Value <> ""
                    TheSheet2.Cells(iRow2, 1) = iRow2
                    iRow2 = iRow2 + 1
                Wend
            Workbooks(Workbooks.Count).Close
            總成轉換_直接貼上 '每一個檔案貼上後需執行的動作模組
        Next i

End Sub