Question

我受到了复制＆＃34; Entry＆＃34;的挑战。从4个excel文件中选择一个名为＆＃34; Data Upload＆＃34;定期。

我是VBA的新手，但我希望有一种自动运行此程序的方法。我试图使用以下代码但接收

运行时错误9下标超出范围

在这一行：

Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)

完整代码：

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)

让我说我输入.xlsm作为模式然后得到

sFname =“。xlsm”

sFname = path＆amp; “.xlsm”＆amp; “.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

将特定工作表复制到新文档 - Excel VBA

1 个答案: