VBA代码复制数据中途触发Run Time 1004错误求助

问题现象 #

执行VBA代码复制数据时，部分合同号（1、2）会在循环到固定行（合同1在count=24，合同2在count=22）时触发错误：

Run-time error 1004
Application-defined or object-defined error.

移除调用WhatPosition函数的代码后，仅填充A、B列可完整运行；合同3、4全程执行正常，且代码此前曾正常工作。

原代码 #

Sub Hourly()
  Call Move("1")
 ' Call Move("2")
 ' Call Move("3")
 ' Call Move("4")
End Sub
Public Function LastRow(sheet, col) As Integer
    Dim wb2 As Excel.Workbook
    Set wb2 = Workbooks.Open("wb2")
        With wb2.Worksheets(sheet)
            Dim lr As Integer:  lr = .Cells(.Rows.count, col).End(xlUp).Row
        End With
    LastRow = lr
End Function
Sub Move(contract)
    Dim wb1 As Excel.Workbook
    Set wb1 = Workbooks.Open("wb1")
    Dim s1 As Excel.Worksheet
    Set s1 = wb1.Worksheets("sheet1")
    Dim wb2 As Excel.Workbook
    Set wb2 = Workbooks.Open("wb2")
    
        Dim oList As ListObject
        Set oList = s1.ListObjects("table1")
        
        Dim oRow As ListRow
        Dim test As Long
        Dim count As Integer
        count = 1
        
        For Each oRow In oList.ListRows
            count = count + 1
            If s1.Cells(count, 5).Value = contract Then
                test = test + 1
                wb2.Worksheets(WhatTab(contract)).Cells(LastRow(WhatTab(contract), 1) + 1, 1).Value = s1.Cells(count, 1).Value
                wb2.Worksheets(WhatTab(contract)).Cells(LastRow(WhatTab(contract), 2) + 1, 2).Value = s1.Cells(count, 3).Value
             
                wb2.Worksheets(WhatTab(contract)).Cells(LastRow(WhatTab(contract), 1), WhatPosition(contract, count, s1)).Value = s1.Cells(count, 6).Value
                wb2.Worksheets(WhatTab(contract)).Cells(LastRow(WhatTab(contract), 1), WhatPosition(contract, count, s1) + 1).Value = s1.Cells(count, 7).Value
            End If
        Next oRow
End Sub

Public Function WhatTab(contract) As String
    If contract = "1" Then
        WhatTab = "1"
    Else
        If contract = "2" Then
        WhatTab = "2"
        Else
            If contract = "3" Then
            WhatTab = "3 e"
            Else
                If contract = "4" Then
                WhatTab = "4 e"
                Else: MsgBox "New Contract Number or Changed Sheet Name"
                End If
            End If
        End If
    End If
End Function
Public Function WhatPosition(contract, counter, sheet) As Integer
    Dim wb1 As Excel.Workbook
    Set wb1 = Workbooks.Open("wb1")
    Dim s1 As Excel.Worksheet
    Set s1 = wb1.Worksheets("sheet1")
    Dim position As String
    position = s1.Cells(counter, 4).Value
    If contract = "3" Then
            If position = "a" Then
            WhatPosition = 3
            Else
                If position = "b" Then
                WhatPosition = 10
                Else
                    If position = "c" Then
                    WhatPosition = 17
                    Else
                        If position = "d" Then
                        WhatPosition = 24
                        Else
                            If position = "e" Then
                            WhatPosition = 31
                            Else
                                If position = "f" Then
                                WhatPosition = 38
                                Else
                                    If position = "g" Then
                                    WhatPosition = 45
                                    Else
                                        If position = "h" Then
                                        WhatPosition = 52
                                        Else
                                            If position = "i" Then
                                            WhatPosition = 59
                                            Else
                                                If position = "j" Then
                                                WhatPosition = 66
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
    Else
        If position = "a" Then
            WhatPosition = 3
            Else
                If position = "b" Then
                WhatPosition = 7
                Else
                    If position = "c" Then
                    WhatPosition = 11
                    Else
                        If position = "d" Then
                        WhatPosition = 15
                        Else
                            If position = "e" Then
                            WhatPosition = 19
                            Else
                                If position = "f" Then
                                WhatPosition = 23
                                Else
                                    If position = "g" Then
                                    WhatPosition = 27
                                    Else
                                        If position = "h" Then
                                        WhatPosition = 31
                                        Else
                                            If position = "i" Then
                                            WhatPosition = 35
                                            Else
                                                If position = "j" Then
                                                WhatPosition = 39
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
    End If
    
End Function

问题根源 #

1. 重复打开工作簿：LastRow和WhatPosition函数每次被调用都会重新打开wb1/wb2，循环中多次执行会导致文件锁定或重复打开冲突，这是1004错误的核心原因。
2. 参数浪费与对象冲突：WhatPosition已传入sheet参数，却重新打开wb1获取工作表，造成对象冗余与潜在冲突。
3. 嵌套If逻辑冗余：多层嵌套If易出现逻辑遗漏，且可读性差。
4. 行号计数方式不合理：依赖count变量手动计数，易出现行号偏移。

修复后的代码 #

1. 优化LastRow函数 #

Public Function LastRow(ws As Worksheet, col As Integer) As Long
    LastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function

2. 重构WhatPosition函数（用Select Case替代嵌套If） #

Public Function WhatPosition(contract As String, counter As Integer, ws As Worksheet) As Integer
    Dim position As String
    position = ws.Cells(counter, 4).Value
    
    Select Case contract
        Case "3"
            Select Case position
                Case "a": WhatPosition = 3
                Case "b": WhatPosition = 10
                Case "c": WhatPosition = 17
                Case "d": WhatPosition = 24
                Case "e": WhatPosition = 31
                Case "f": WhatPosition = 38
                Case "g": WhatPosition = 45
                Case "h": WhatPosition = 52
                Case "i": WhatPosition = 59
                Case "j": WhatPosition = 66
                Case Else
                    MsgBox "未知职位: " & position
                    WhatPosition = 0
            End Select
        Case Else
            Select Case position
                Case "a": WhatPosition = 3
                Case "b": WhatPosition = 7
                Case "c": WhatPosition = 11
                Case "d": WhatPosition = 15
                Case "e": WhatPosition = 19
                Case "f": WhatPosition = 23
                Case "g": WhatPosition = 27
                Case "h": WhatPosition = 31
                Case "i": WhatPosition = 35
                Case "j": WhatPosition = 39
                Case Else
                    MsgBox "未知职位: " & position
                    WhatPosition = 0
            End Select
    End Select
End Function

3. 优化Move过程（避免重复打开工作簿，简化行号获取） #

Sub Move(contract As String)
    Dim wb1 As Workbook, wb2 As Workbook
    Dim s1 As Worksheet, targetWs As Worksheet
    Dim oList As ListObject
    Dim oRow As ListRow
    Dim targetRow As Long
    Dim posCol As Integer
    
    ' 检查工作簿是否已打开，避免重复打开
    On Error Resume Next
    Set wb1 = Workbooks("wb1.xlsx") ' 建议补充文件扩展名
    If wb1 Is Nothing Then
        Set wb1 = Workbooks.Open("wb1.xlsx")
    End If
    Set wb2 = Workbooks("wb2.xlsx")
    If wb2 Is Nothing Then
        Set wb2 = Workbooks.Open("wb2.xlsx")
    End If
    On Error GoTo 0
    
    Set s1 = wb1.Worksheets("sheet1")
    Set oList = s1.ListObjects("table1")
    Set targetWs = wb2.Worksheets(WhatTab(contract))
    
    For Each oRow In oList.ListRows
        If oRow.Range(5).Value = contract Then
            targetRow = LastRow(targetWs, 1) + 1
            
            ' 填充A、B列
            targetWs.Cells(targetRow, 1).Value = oRow.Range(1).Value
            targetWs.Cells(targetRow, 2).Value = oRow.Range(3).Value
            
            ' 获取目标列号并填充数据
            posCol = WhatPosition(contract, oRow.Range.Row, s1)
            If posCol > 0 Then
                targetWs.Cells(targetRow, posCol).Value = oRow.Range(6).Value
                targetWs.Cells(targetRow, posCol + 1).Value = oRow.Range(7).Value
            End If
        End If
    Next oRow
End Sub

4. 重构WhatTab函数 #

Public Function WhatTab(contract As String) As String
    Select Case contract
        Case "1": WhatTab = "1"
        Case "2": WhatTab = "2"
        Case "3": WhatTab = "3 e"
        Case "4": WhatTab = "4 e"
        Case Else
            MsgBox "未知合同号或工作表名称已更改"
            WhatTab = ""
    End Select
End Function

修复要点总结 #

• 移除函数中重复打开工作簿的逻辑，避免文件锁定冲突
• 用Select Case替代多层嵌套If，提升代码可读性与逻辑完整性
• 增加工作簿已打开的检查，避免重复打开操作
• 直接使用ListRow.Range访问表格单元格，替代手动计数，避免行号偏移
• 增加无效职位的判断，防止写入错误位置导致的报错

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