VBA 代码适用于 Excel 2010 但不适用于 Excel 2013

Question

我在 VBA 中有代码，可以将不同工作簿中具有相同选项卡名称的工作表复制到一个工作簿中。 代码从中提取的工作簿位于一个文件夹中。 该代码在 Excel 2010 中运行良好，但是当我在 Excel 2013 中运行它时，我收到以下 1004 错误消息：“抱歉，我们找不到 ....xlsx。它是否可能被移动、重命名或删除。 ” 我不确定从哪里开始进行故障排除。 有没有人遇到过这个问题或有任何想法为什么它会在 Excel 2010 而不是 Excel 2013 中正常工作？ 谢谢你。

Sub CombineSheets()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

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

Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = "PathName\Inputs"
ChDir sPath
sFname = "*"
sFname = Dir(sPath & "\" & sFname & ".xlsx*", vbNormal) <Code bombs here>
wSht = ("Risks")
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

Answer 1

您确定此代码以前有效吗？

如果是这样，那么您的应用程序的默认文件路径可能已更改。 您可以使用Debug.Print Application.DefaultFilePath进行检查。无论如何，最好在sPath变量中明确定义完整路径名。

如果您想获取旧版 Excel 文档，则Dir函数中的字符串可能只是“*.xls*”（但这也会收集启用宏的工作簿）。 我想知道这是否最初是为了在您的代码中使用星号。

无需激活该窗口，但您可能需要一个错误处理行来检查工作簿中是否存在“风险”表。

您的代码中也有一些冗余，所以整个事情应该可以正常工作，如下所示：

Sub CombineSheets()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

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

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    sPath = "PathName\Inputs" 'make this a full path eg "C:\..."
    sFname = Dir(sPath & "\" & "*.xls*", vbNormal)
    Do Until sFname = ""

        'skip if it's this workbook
        If sFname <> ThisWorkbook.Name Then
            Set wBk = Workbooks.Open(sPath & "\" & sFname)

            'check a "Risks" sheet exists
            Set wSht = Nothing
            On Error Resume Next
            Set wSht = wBk.Sheets("Risks")
            On Error GoTo 0

            If Not wSht Is Nothing Then
                wSht.Copy Before:=ThisWorkbook.Sheets(1)
            End If

            wBk.Close False

        End If

        sFname = Dir()
    Loop
    ActiveWorkbook.Save
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub