VBA 循环遍历文件夹中的文件并复制/粘贴到主文件

VBA Loop through files in folder and copy/paste to master file

提问by Ryan

I'm working on a project that has 3 files in a folder and one master template. Here is what I want to do:

我正在处理一个文件夹中包含 3 个文件和一个主模板的项目。这是我想要做的：

1. Automatically loop through these files then copy the content and paste it to master file.
2. Each WHOLE file will be pasted to a new worksheet in the master file.
3. The new worksheet's name will be the same as file's name.

1. 自动循环这些文件，然后复制内容并将其粘贴到主文件。
2. 每个 WHOLE 文件都将粘贴到主文件中的新工作表中。
3. 新工作表的名称将与文件名称相同。

I tried to write some codes but I'm not experienced on VBA. The codes below are not working properly and missing functions 2 and 3. Please help!

我尝试编写一些代码，但我对 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

采纳答案by Shai Rado

Try the code below (explanations are inside the code comments):

试试下面的代码（解释在代码注释中）：

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