Excel VBA操作SharePoint远程文件偶发失效问题求助

我编写了一段VBA代码，功能是在当前工作簿的“Vertical”工作表中查找指定值，接着打开SharePoint上的远程工作簿，在其中搜索该值，找到后将对应工作表完整复制到当前工作簿的“Database”工作表。但代码存在偶发异常：有时能正常运行，有时仅打开远程工作簿却无后续操作。已确认MsgBox "The search value is " & sponAcc.Offset(0, 1).Value能正确显示搜索值，这部分无问题。使用的Excel版本为Microsoft® Excel® for Microsoft 365 MSO（Version 2308 Build 16.0.16731.20542）64位，原代码如下：

Private Sub Search_DB_ANM()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim wsVertical As Worksheet, wsDatabase As Worksheet
    Dim lastRow As Long
    Dim sponAcc As Range, foundRange As Range
    
    Dim sharePointPath As String
    
    ' Set references to the workbooks and sheets
    Set wb1 = ThisWorkbook
    Set wsVertical = wb1.Sheets("Vertical")
    Set wsDatabase = wb1.Sheets("Database")

    ' SharePoint path to the second workbook
    sharePointPath = "https://corp.sharepoint.com/:x:/r/sites/Shared%20Documents/XXXX%20YYYY.xlsx"
     
    ' Clear the Database sheet
    wsDatabase.Cells.Clear
    
    ' Find the sponsor account value in workbook1
    lastRow = wsVertical.Cells(wsVertical.Rows.Count, "A").End(xlUp).Row
    Set sponAcc = wsVertical.Range("A1:A" & lastRow).Find("Sponsoraccount", LookIn:=xlValues, LookAt:=xlPart)
    
    MsgBox "The search value is  " & sponAcc.Offset(0, 1).Value
    ' Open workbook2 from SharePoint
    Dim initialScreenUpdating As Boolean
    Dim initialDisplayAlerts As Boolean
    initialScreenUpdating = Application.ScreenUpdating
    initialDisplayAlerts = Application.DisplayAlerts

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb2 = Workbooks.Open(sharePointPath)

    ' Check if the workbook was opened successfully
    If wb2 Is Nothing Then
        MsgBox "Unable to open the workbook."
       GoTo CleanExit
    End If

   If Not sponAcc Is Nothing Then
        ' Search for the content in workbook2
        wb2.Sheets("Algemeen").Select
        For Each wsVertical In wb2.Sheets
            Set foundRange = wsVertical.Cells.Find(sponAcc.Offset(0, 1).Value, LookIn:=xlValues)
            
            If Not foundRange Is Nothing Then
                ' Copy the contents of the found tab to the Database sheet
                foundRange.Worksheet.UsedRange.Copy
                wsDatabase.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme

                ' Autofit rows and columns
                wsDatabase.Cells.EntireColumn.AutoFit
                wsDatabase.Cells.EntireRow.AutoFit
                
                ' Exit the loop after finding and copying the data
                Exit For
                GoTo CleanExit
            End If
        Next wsVertical
        
        ' If no value is found after searching all sheets
        If foundRange Is Nothing Then
            MsgBox "Unable to find the value."
            GoTo CleanExit
        End If
     
End If

CleanExit:
    ' Close workbook2 without saving and return to workbook1
    If Not wb2 Is Nothing Then wb2.Close SaveChanges:=False
    wb1.Activate
    wsDatabase.Activate

    ' Restore initial application settings
    Application.ScreenUpdating = initialScreenUpdating
    Application.DisplayAlerts = initialDisplayAlerts
End Sub

问题根源与修复方案 #

1. 变量重名冲突

原代码中wsVertical同时被用作当前工作簿的工作表引用和遍历远程工作簿的循环变量，会覆盖原有引用，这是偶发异常的核心原因。需将循环变量改为其他名称，比如wsRemote。

2. Find方法参数不稳定

Find方法会继承Excel上次使用的搜索参数（如匹配方式、搜索方向），导致偶发查找失败。需显式指定关键参数，避免依赖默认值。

3. 冗余的Select操作

wb2.Sheets("Algemeen").Select属于无意义操作，VBA无需选中对象即可执行操作，此类操作可能引发界面相关的偶发问题。

4. 缺失空值判断

未判断sponAcc是否为空，若找不到"Sponsoraccount"会导致后续代码报错。

修复后的完整代码 #

Private Sub Search_DB_ANM()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim wsVertical As Worksheet, wsDatabase As Worksheet
    Dim wsRemote As Worksheet ' 重命名循环变量，避免冲突
    Dim lastRow As Long
    Dim sponAcc As Range, foundRange As Range
    
    Dim sharePointPath As String
    
    ' 初始化查找结果变量，避免残留值干扰
    Set foundRange = Nothing
    
    ' 设置工作簿和工作表引用
    Set wb1 = ThisWorkbook
    Set wsVertical = wb1.Sheets("Vertical")
    Set wsDatabase = wb1.Sheets("Database")

    ' SharePoint远程工作簿路径
    sharePointPath = "https://corp.sharepoint.com/:x:/r/sites/Shared%20Documents/XXXX%20YYYY.xlsx"
     
    ' 清空Database工作表
    wsDatabase.Cells.Clear
    
    ' 在当前工作簿查找"Sponsoraccount"
    lastRow = wsVertical.Cells(wsVertical.Rows.Count, "A").End(xlUp).Row
    Set sponAcc = wsVertical.Range("A1:A" & lastRow).Find("Sponsoraccount", LookIn:=xlValues, LookAt:=xlPart)
    
    ' 新增空值判断
    If sponAcc Is Nothing Then
        MsgBox "未找到""Sponsoraccount""标识"
        GoTo CleanExit
    End If
    
    MsgBox "搜索值为: " & sponAcc.Offset(0, 1).Value
    
    ' 保存应用初始设置
    Dim initialScreenUpdating As Boolean
    Dim initialDisplayAlerts As Boolean
    initialScreenUpdating = Application.ScreenUpdating
    initialDisplayAlerts = Application.DisplayAlerts

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 捕获打开工作簿的异常
    On Error Resume Next
    Set wb2 = Workbooks.Open(sharePointPath)
    On Error GoTo 0
    
    ' 检查工作簿是否打开成功
    If wb2 Is Nothing Then
        MsgBox "无法打开远程工作簿，请检查路径或权限。"
        GoTo CleanExit
    End If

    ' 在远程工作簿中搜索目标值，显式指定Find参数
    For Each wsRemote In wb2.Sheets
        Set foundRange = wsRemote.Cells.Find( _
            What:=sponAcc.Offset(0, 1).Value, _
            LookIn:=xlValues, _
            LookAt:=xlPart, ' 可根据需求改为xlWhole
            SearchOrder:=xlByRows, _
            MatchCase:=False _
        )
        
        If Not foundRange Is Nothing Then
            ' 复制工作表内容到Database
            foundRange.Worksheet.UsedRange.Copy
            wsDatabase.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme

            ' 自适应行列
            wsDatabase.Cells.EntireColumn.AutoFit
            wsDatabase.Cells.EntireRow.AutoFit
            
            Exit For ' 找到后退出循环
        End If
    Next wsRemote
    
    ' 判断是否找到目标值
    If foundRange Is Nothing Then
        MsgBox "在远程工作簿中未找到指定值。"
    End If

CleanExit:
    ' 关闭远程工作簿（如果已打开）
    If Not wb2 Is Nothing Then
        wb2.Close SaveChanges:=False
    End If
    
    ' 恢复应用设置
    Application.ScreenUpdating = initialScreenUpdating
    Application.DisplayAlerts = initialDisplayAlerts
    
    ' 激活当前工作簿的Database工作表
    wb1.Activate
    wsDatabase.Activate
End Sub

内容的提问来源于stack exchange，提问作者Frotsie