使用With激活工作簿后Variant变量丢失，VBA运行时错误1004求助

问题背景 #

有一个使用多年的Excel工作簿，包含大量VBA代码。其中一段工作表激活事件代码，需从指定文件夹读取子文件夹名并生成数据验证列表。目前代码能成功生成存储文件夹名的变量ListWB，但在通过With操作ActiveWorkbook创建数据验证列表时，触发运行时错误'1004'：应用程序定义或对象定义错误，该功能数年前突然失效。

报错代码片段 #

错误触发在With Selection.Validation代码块处，完整代码如下：

Private Sub Worksheet_Activate()
'Sub Existing_client_list()

Dim SourceFolderName As String
Dim ListWB As Variant
Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim FolderItem As Scripting.Folder

SourceFolderName = ThisWorkbook.Sheets("LUT").Range("B3").Value

Set fso = New Scripting.FileSystemObject
Set SourceFolder = fso.GetFolder(SourceFolderName)

For Each SourceFolder In SourceFolder.SubFolders
    ListWB = ListWB & "," & repalce_comma_Semi_string(SourceFolder.Name)
Next SourceFolder

With ActiveWorkbook
    .Sheets("Customer Details").Unprotect
    
    .Sheets("Customer Details").Range("C10").Select
End With

With Selection.Validation
' 在此处触发运行时错误'1004'：应用程序定义或对象定义错误
On Error Resume Next
.DELETE
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, Operator:= _
xlBetween, Formula1:=ListWB
.ShowError = False

End With

Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing

With ActiveWorkbook
    .Sheets("Customer Details").Unprotect
    
    .Sheets("Customer Details").Range("Report_Language").Select
End With

With Selection.Validation

On Error Resume Next
.DELETE
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, Operator:= _
xlBetween, Formula1:="=Report_Language_List"
.ShowError = False

End With
End Sub

问题根源与修复方案 #

1. 对象重复赋值导致引用混乱 #

代码中For Each SourceFolder In SourceFolder.SubFolders将循环变量命名为SourceFolder，直接覆盖了之前定义的文件夹对象，导致后续对象引用逻辑混乱。

• 修复：使用已声明但未使用的FolderItem作为循环变量：

  For Each FolderItem In SourceFolder.SubFolders
      ListWB = ListWB & "," & repalce_comma_Semi_string(FolderItem.Name)
  Next FolderItem
  

2. 未初始化的变量格式错误 #

ListWB作为Variant变量未初始化，首次拼接会生成",文件夹名"的格式，无文件夹时变量为空，直接用于数据验证会触发格式错误。

• 修复：初始化变量并移除开头多余逗号：

  ListWB = "" ' 初始化变量
  For Each FolderItem In SourceFolder.SubFolders
      ListWB = ListWB & "," & repalce_comma_Semi_string(FolderItem.Name)
  Next FolderItem
  ' 移除开头的逗号
  If Len(ListWB) > 0 Then ListWB = Mid(ListWB, 2)
  

3. 依赖Selection的不稳定操作 #

依赖Selection容易因活动对象意外变更导致错误，直接引用单元格对象更可靠。

• 修复：替换Select和Selection操作，直接通过工作表对象引用单元格：

  With ActiveWorkbook.Sheets("Customer Details")
      .Unprotect
      With .Range("C10").Validation
          On Error Resume Next
          .Delete
          On Error GoTo 0 ' 恢复正常错误捕获
          If Len(ListWB) > 0 Then
              .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                   Operator:=xlBetween, Formula1:=ListWB
          End If
          .ShowError = False
      End With
  End With
  

4. 潜在的路径与权限问题 #

功能数年前突然失效，可能是文件夹路径变更、Excel读取权限不足或Microsoft Scripting Runtime引用丢失：

• 检查LUT工作表B3单元格的路径是否正确，确保Excel有该文件夹的读取权限；
• 确认VBA工程已引用Microsoft Scripting Runtime（工具→引用→勾选对应项）。

5. 错误处理优化 #

On Error Resume Next会掩盖其他错误，建议在必要操作后恢复正常错误捕获，避免隐藏后续代码问题。

修复后完整代码 #

Private Sub Worksheet_Activate()
    Dim SourceFolderName As String
    Dim ListWB As String ' 改为String类型更明确
    Dim fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FolderItem As Scripting.Folder

    SourceFolderName = ThisWorkbook.Sheets("LUT").Range("B3").Value

    Set fso = New Scripting.FileSystemObject
    Set SourceFolder = fso.GetFolder(SourceFolderName)

    ListWB = ""
    For Each FolderItem In SourceFolder.SubFolders
        ListWB = ListWB & "," & repalce_comma_Semi_string(FolderItem.Name)
    Next FolderItem
    ' 移除开头的逗号
    If Len(ListWB) > 0 Then ListWB = Mid(ListWB, 2)

    With ActiveWorkbook.Sheets("Customer Details")
        .Unprotect
        ' 处理C10的数据验证
        With .Range("C10").Validation
            On Error Resume Next
            .Delete
            On Error GoTo 0
            If Len(ListWB) > 0 Then
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                     Operator:=xlBetween, Formula1:=ListWB
            End If
            .ShowError = False
        End With
        ' 处理Report_Language的数据验证
        With .Range("Report_Language").Validation
            On Error Resume Next
            .Delete
            On Error GoTo 0
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                 Operator:=xlBetween, Formula1:="=Report_Language_List"
            .ShowError = False
        End With
        .Protect ' 按需重新保护工作表
    End With

    Set FolderItem = Nothing
    Set SourceFolder = Nothing
    Set fso = Nothing
End Sub

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