将特定工作表复制到新文档 - 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