我正在尝试从表中获取数据，然后根据员工的职位和合同号将其复制到另一张表中。问题是，在某些合约（但不是全部）上，代码将在表中途停止执行，并给出运行时 1004：应用程序定义或对象定义错误。奇怪的是，到目前为止，代码都运行得很好。当我尝试在 Move 函数的 for 循环中调用 WhatPosition 时，代码抛出错误。我也尝试过在没有这两行的情况下运行代码，只填写列 a 和 b，并且它在整个列表中工作得很好。
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
重申一下，代码（包括调用 WhatPosition 的代码）按预期工作并复制数据，直到循环到列表的中间（table1 位于 wb1 中的sheet1 上）。它在合同 1 和 2、3 和 4 上一致地给出了这个问题，总是工作得很好。它总是停在完全相同的行处，合约 1 计数为 24，合约 2 计数为 22；表中的这些行没有任何异常。
下面有很多建议。 已编译但未测试：
Sub Hourly()
Move "1" 'use of `Call` is deprecated
Move "2"
Move "3"
Move "4"
End Sub
Sub Move(contract As String)
Dim wb1 As Workbook, s1 As Worksheet, wb2 As Excel.Workbook
Dim oList As ListObject, rw As Range, colPos As Long, position As String
Dim test As Long, theRow1 As Long, theRow2 As Long, wsDest As Worksheet
Set wb1 = Workbooks.Open("wb1")
Set s1 = wb1.Worksheets("sheet1")
Set oList = s1.ListObjects("table1")
Set wb2 = Workbooks.Open("wb2")
Set wsDest = wb2.Worksheets(WhatTab(contract)) 'destination worksheet
For Each rw In oList.DataBodyRange.Rows 'for each row of data in `table1`
If rw.Cells(5).Value = contract Then 'contract matches?
theRow1 = LastRow(wsDest, 1)
theRow2 = LastRow(wsDest, 2)
position = rw.Cells(4).Value
colPos = WhatColumn(contract, position)
With wsDest
.Cells(theRow1 + 1, 1).Value = rw.Cells(1).Value
.Cells(theRow2 + 1, 2).Value = rw.Cells(3).Value
.Cells(theRow1, colPos).Value = rw.Cells(6).Value
.Cells(theRow1, colPos + 1).Value = rw.Cells(7).Value
End With
End If
Next rw
End Sub
Public Function LastRow(ws As Worksheet, col) As Long 'prefer Long over Integer
With ws
LastRow = .Cells(.Rows.count, col).End(xlUp).Row
End With
End Function
Public Function WhatTab(contract As String) As String
Select Case contract 'better with Select Case
Case "1", "2": WhatTab = contract
Case "3", "4": WhatTab = contract & " e"
Case Else: MsgBox "New Contract Number or Changed Sheet Name"
End Select
End Function
Public Function WhatColumn(contract As String, position As String) As Long
Dim i As Long, incr As Long
If position Like "[a-j]" Then 'position is in range a-j?
i = asc(position) - 96 'a=1, b=2 etc
incr = IIf(contract = "3", 7, 4) 'increment by 7 or by 4 ?
WhatColumn = 3 + ((i - 1) * 7) 'calculate column position
End If
End Function