將特定工作表複製到新文檔 - Excel VBA

Question

我一直在將4個excel文件中的「Entry」選項卡定期複製到一個名爲「Data Upload」的新文檔中。

我是VBA的新手，但希望有一種自動化的方式來運行此過程。我已經嘗試使用下面的代碼，但收到

運行時錯誤9下標越界

在此行中：

全碼：

Sub CombineSheets() 

    Dim sPath As String 
    Dim sFname As String 
    Dim wBk As Workbook 
    Dim wSht As Variant 

    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    sPath = InputBox("Enter a full path to workbooks") 
    ChDir sPath 
    sFname = InputBox("Enter a filename pattern") 
    sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) 
    wSht = InputBox("Enter a worksheet name to copy") 

    Do Until sFname = "" 
     Set wBk = Workbooks.Open(sFname) 
     Windows(sFname).Activate 
     Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) 
     wBk.Close False 
     sFname = Dir() 
    Loop 

    ActiveWorkbook.Save 

    Application.EnableEvents = True 
    Application.ScreenUpdating = True 

End Sub 

真的很感激任何意見，哪裏出錯或簡單的例子想辦法做到這一點。

Answer 1

我覺得你的問題是不是在這裏，：

sFname = InputBox("Enter a filename pattern") 
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) 

比方說，我inputed .XLSM爲一種模式，然後我得到

sFname = 「.XLSM」

sFname =路徑&「 .xlsm「&」.xl *「

這是無效的。

或者，表格可能不存在您正在嘗試複製。

注意：您需要處理表單可能不存在的情況下進行復制，或者由於無效的文件掩碼條目而未找到工作簿，並且還要決定是要重命名複製的表單還是離開他們作爲mySheet，mySheet（2）等。

Sub CombineSheets() 
Dim sPath As String 
Dim sFname As String 
Dim wBk As Workbook 
Dim wSht As Variant 

Application.EnableEvents = False 
Application.ScreenUpdating = False 

sPath = InputBox("Enter a full path to workbooks") 
ChDir sPath 

sFname = InputBox("Enter a filename pattern") 'You will need some checks added here e.g. did user input ".xlsm" or "xlsm" etc 

sFname = Dir(sPath & "\" & "*" & sFname, vbNormal) 'Additional * added to match different file names for the mask 
wSht = InputBox("Enter a worksheet name to copy") 

Do Until sFname = "" 

    On Error Resume Next 
    Set wBk = Workbooks.Open(sFname) 
    Windows(sFname).Activate 
    Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) 
    wBk.Close False 
    On Error GoTo 0 

    sFname = Dir() 
Loop 

ActiveWorkbook.Save 
Application.EnableEvents = True 
Application.ScreenUpdating = True 

End Sub