將許多excel文件合併到一個具有不同工作表的新文件中

Question

我正在嘗試合併文件夾中的許多excel文件（工作簿）。 我的問題是，我想移動不同的工作表到新的Excel文件。 目前我的代碼只能從這些不同的文件中移動一張紙。

例子： 我有3個Excel文件名爲

• 1.xlsx
• 2.xlsx
• 3.xlsx

所有3個文件有3張在這和我希望從1.xlsx獲取sheet1，從2.xlsx獲取sheet1和sheet2，最後從3.xlsx獲取sheet3並放入新的excel文件。

我的代碼目前只能從每個文件中取一張（同一張數）並放入新文件。

我的代碼，以便票價：

Sub MergeMultiSheets() 
Dim wbDst As Workbook 
Dim wbSrc As Workbook 
Dim wsSrc As Worksheet 
Dim Path As String 
Dim Filename As String 

Application.DisplayAlerts = False 
Application.EnableEvents = False 
Application.ScreenUpdating = False 
path = "C:\Users\*ChangeThis*\Desktop\merge" 
Set wbDst = Workbooks.Add(xlWBATWorksheet) 
Filename = Dir(path & "\*.xlsx", vbNormal) 

If Len(Filename) = 0 Then Exit Sub 

Do Until Filename = "" 
    Set wbSrc = Workbooks.Open(Filename:=path & "\" & Filename) 

    sheet = 1 
    Set wsSrc = wbSrc.Worksheets(sheet) 
    wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count) 

    wbSrc.Close False 
    Filename = Dir() 
Loop 
wbDst.Worksheets(1).Delete 

Application.DisplayAlerts = True 
Application.EnableEvents = True 
Application.ScreenUpdating = True 

End Sub 

提前

Answer 1

許多謝謝您通過您的文件夾中找到當前工作簿中所有表需要循環。

嘗試下面的代碼：

Sub MergeMultiSheets() 

Dim wbDst As Workbook 
Dim wbSrc As Workbook 
Dim wsSrc As Worksheet 
Dim Path As String 
Dim Filename As String 

Application.DisplayAlerts = False 
Application.EnableEvents = False 
Application.ScreenUpdating = False 

Path = "C:\Users\*ChangeThis*\Desktop\merge"  

Set wbDst = Workbooks.Add(xlWBATWorksheet) 
Filename = Dir(Path & "\*.xlsx", vbNormal) 

If Len(Filename) = 0 Then Exit Sub 

Do Until Filename = "" 
    Set wbSrc = Workbooks.Open(Filename:=Path & "\" & Filename) 

    Sheet = 1 
    ' ****** you need to loop on all sheets per Excel workbook found in Folder ****** 
    For Each wsSrc In wbSrc.Sheets   
     wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)   
    Next wsSrc 

    wbSrc.Close False 
    Filename = Dir() 
Loop 
wbDst.Worksheets(1).Delete 

Application.DisplayAlerts = True 
Application.EnableEvents = True 
Application.ScreenUpdating = True 

End Sub