上传同一文件触发报错：Excel VBA文件对比工具故障排查求助

嘿，我来帮你梳理下这个报错的根源，以及对应的修复方案！

你遇到的报错本质是当选择同一个文件作为File1和File2时，第二次执行Workbooks.Open(File2)会失败——因为该文件已经被打开了，默认情况下Workbooks.Open没法重复打开已处于打开状态的文件，这会导致wbCopyF2对象无法正确创建，后续引用无效对象时就会触发报错（报错指向LR1行其实是连锁问题的表象）。

接下来给你针对性的修复方案，同时优化代码的健壮性：

1. 新增「检查工作簿是否已打开」的辅助函数 #

先写一个小函数，用来判断目标文件是否已经在Excel中打开，如果打开了就直接引用该工作簿，否则再以只读模式打开（只读模式能避免权限冲突，也支持重复引用同一文件）：

Function GetWorkbook(ByVal filePath As String) As Workbook
    Dim wb As Workbook
    On Error Resume Next
    ' 尝试引用已打开的工作簿
    Set wb = Workbooks(Filename:=filePath)
    On Error GoTo 0
    
    If wb Is Nothing Then
        ' 文件未打开，以只读模式打开
        Set wb = Workbooks.Open(filePath, ReadOnly:=True)
    End If
    Set GetWorkbook = wb
End Function

2. 修改原代码的核心逻辑 #

把原来直接调用Workbooks.Open的部分替换成上面的函数，同时记录哪些工作簿是我们主动打开的，避免误关用户原本就打开的文件：

Dim File1 As String, File2 As String
Dim wbCopyF1 As Workbook, wbCopyF2 As Workbook, wbCopyT As Workbook
Dim wsCopyF1 As Worksheet, wsCopyF2 As Worksheet
Dim LR1 As Long, LR2 As Long
Dim isF1OpenedByUs As Boolean, isF2OpenedByUs As Boolean

' 初始化标记变量，记录是否是我们打开的工作簿
isF1OpenedByUs = False
isF2OpenedByUs = False

Set wbCopyT = Workbooks.Add
File1 = txtBoxOld.Text
File2 = txtBoxNew.Text

' 获取或打开File1
Set wbCopyF1 = GetWorkbook(File1)
If wbCopyF1 Is Nothing Then
    MsgBox "无法打开文件：" & File1, vbExclamation
    Exit Sub
End If
' 判断是否是我们打开的（如果原本就存在，就不要关闭）
isF1OpenedByUs = (Workbooks(Filename:=File1) Is Nothing)

Set wsCopyF1 = wbCopyF1.Sheets(1)

' 获取或打开File2（支持和File1是同一个文件）
Set wbCopyF2 = GetWorkbook(File2)
If wbCopyF2 Is Nothing Then
    MsgBox "无法打开文件：" & File2, vbExclamation
    Exit Sub
End If
isF2OpenedByUs = (Workbooks(Filename:=File2) Is Nothing)

Set wsCopyF2 = wbCopyF2.Sheets(1)

' 处理第一个文件的筛选和复制
LR1 = wsCopyF1.Range("A" & wsCopyF1.Rows.Count).End(xlUp).Row
' 先清除原有筛选，避免残留筛选影响结果
If wsCopyF1.AutoFilterMode Then wsCopyF1.AutoFilterMode = False
wsCopyF1.Range("A2:D2").AutoFilter Field:=1, Criteria1:=Me.txtBoxApplication, VisibleDropDown:=True
' 处理无匹配数据的情况，避免SpecialCells报错
On Error Resume Next
wsCopyF1.Range("A2:D" & LR1).SpecialCells(xlCellTypeVisible).Copy
If Err.Number <> 0 Then
    MsgBox "文件1中未找到匹配的数据", vbInformation
Else
    wbCopyT.Sheets("Sheet1").Range("A1").PasteSpecial
End If
On Error GoTo 0
' 只有我们打开的文件才关闭
If isF1OpenedByUs Then wbCopyF1.Close SaveChanges:=False

' 处理第二个文件的筛选和复制
LR2 = wsCopyF2.Range("A" & wsCopyF2.Rows.Count).End(xlUp).Row
If wsCopyF2.AutoFilterMode Then wsCopyF2.AutoFilterMode = False
wsCopyF2.Range("A2:D2").AutoFilter Field:=1, Criteria1:=Me.txtBoxApplication, VisibleDropDown:=True
On Error Resume Next
wsCopyF2.Range("A2:D" & LR2).SpecialCells(xlCellTypeVisible).Copy
If Err.Number <> 0 Then
    MsgBox "文件2中未找到匹配的数据", vbInformation
Else
    wbCopyT.Sheets("Sheet2").Range("A1").PasteSpecial
End If
On Error GoTo 0
If isF2OpenedByUs Then wbCopyF2.Close SaveChanges:=False

几个关键优化点的说明 #

• 用wsCopyF1.Rows.Count代替Rows.Count：避免当前活动工作表不是目标工作表时，引用错误的行数。
• 增加无匹配数据的错误处理：防止筛选后没有可见单元格，导致SpecialCells(xlCellTypeVisible)触发报错。
• 记录工作簿的打开状态：避免关闭用户原本就打开的文件，提升工具的友好性。

这样修改后，即使你选择同一个文件作为新旧文件进行对比，代码也能正常运行，不会再触发报错啦！

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