VBA循環遍歷文件夾中的文件並複製/粘貼到主文件

Question

我正在處理一個文件夾和一個主模板中有3個文件的項目。這是我想要做的：

1. 自動循環這些文件，然後複製內容並將其粘貼到主文件。
2. 每個整體文件將被粘貼到主文件中的新工作表中。
3. 新工作表的名稱將與文件名相同。

我試着寫一些代碼，但我沒有在VBA上體驗過。下面的代碼工作不正常，缺少功能2和3.請幫助！

Sub AllFiles() 
Application.EnableCancelKey = xlDisabled 
Dim folderPath As String 
Dim Filename As String 
Dim wb As Workbook 
Dim sh As Worksheet 
folderPath = "C:\Users\Ryan\Desktop\LoopThroughFolders\Sample1\" 'contains folder path 
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
Filename = Dir(folderPath & "*.xlsx") 
Do While Filename <> "" 
    Application.ScreenUpdating = False 

    Set wb = Workbooks.Open(folderPath & Filename) 

    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy 

    'Not working well here as it will be overwritten by the next file 
    Workbooks("Master Template").Worksheets("Sheet1").Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues 

    Workbooks(Filename).Close 
    Filename = Dir 
Loop 
    Application.ScreenUpdating = True 
End sub 

Answer 1

嘗試下面的代碼（解釋是代碼註釋裏）：

Option Explicit 

Sub AllFiles() 

Application.EnableCancelKey = xlDisabled 

Dim folderPath As String 
Dim Filename As String 
Dim wb As Workbook 
Dim Masterwb As Workbook 
Dim sh As Worksheet 
Dim NewSht As Worksheet 
Dim FindRng As Range 
Dim PasteRow As Long 

' set master workbook 
Set Masterwb = Workbooks("Master Template.xlsx") 

folderPath = "C:\Users\Ryan\Desktop\LoopThroughFolders\Sample1\" 'contains folder path 

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\" 
Application.ScreenUpdating = False 

Filename = Dir(folderPath & "*.xls*") 
Do While Filename <> "" 
    Set wb = Workbooks.Open(folderPath & Filename) 

    If Len(wb.Name) > 35 Then 
     MsgBox "Sheet's name can be up to 31 characters long, shorten the Excel file name" 
     wb.Close False 
     GoTo Exit_Loop 
    Else 
     ' add a new sheet with the file's name (remove the extension) 
     Set NewSht = Masterwb.Worksheets.Add(After:=Masterwb.Worksheets(1)) 
     NewSht.Name = Replace(wb.Name, ".xlsx", "") 
    End If 

    ' loop through all sheets in opened wb 
    For Each sh In wb.Worksheets 
     ' get the first empty row in the new sheet 
     Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False) 

     If Not FindRng Is Nothing Then ' If find is successful 
      PasteRow = FindRng.Row + 1 
     Else ' find was unsuccessfull > new empty sheet, should paste at the first row 
      PasteRow = 1 
     End If 

     sh.UsedRange.Copy 
     NewSht.Range("A" & PasteRow).PasteSpecial xlPasteValues 
    Next sh 
    wb.Close False 

Exit_Loop: 
    Set wb = Nothing 
    Filename = Dir 
Loop 

Application.ScreenUpdating = True 

End Sub