两个Excel工作簿间循环查找复制替换失效，VBA代码报错求排查

原始问题 #

我为这个问题费尽心思，查阅了大量相关资料仍无法定位错误点。目前我遇到的报错似乎与我定义Range范围的方式有关，但我不理解出错的原因。
出于工作保密及保护规则要求，我无法分享相关工作簿，以下是我的VBA代码：

Sub Compare_DataSheet2021_ImportSheet()

Application.ScreenUpdating = False 'Switch off automatic screen updating
    MsgBox "Screen Updating Off", vbInformation

Sheets("Import Sheet").Visible = True 'Unhide the Import Sheet
    MsgBox "Unhidden Import Sheet", vbInformation
Sheets("Import Sheet").Unprotect "ImportSheet" 'Unprotect Import Sheet
     MsgBox "Unprotected Import Sheet", vbInformation

Dim wb As Workbook
    MsgBox "Opening Central Tracker", vbInformation
Set wb = Workbooks.Open("Y:\GLOBAL\LEGAL\LCCTeam\Test Folder\Central Tracker - Live.xlsm")

If wb.ReadOnly Then 'Check to see if the tracker is already open
ActiveWorkbook.Close
    MsgBox "Central Tracker is already in use. Speak to the Inbox Manager"
    Exit Sub
End If

Application.CutCopyMode = False 'This clears the clipboard
Workbooks("Central Tracker - Live.xlsm").Worksheets("Data 2021").Activate

    MsgBox "Switching to Import Sheet", vbInformation
Workbooks("Import Tracker Test.xlsm").Worksheets("Import Sheet").Activate

Dim i As Range 'Set a variable as a Ranage Data Type so that it can hold or store a range of values
Dim D As Range

    MsgBox "Setting i Range in Import Tracker", vbInformation
With Workbooks("Import Tracker Test.xlsm").Worksheets("Import Sheet")
Workbooks("Import Tracker Test.xlsm").Worksheets("Import Sheet").Activate
Set i = Range("B2:B" & .Cells(.Rows.Count, "B").End(xlIp).Row)
    MsgBox "i Range Set", vbInformation
End With

    MsgBox "Setting D Range in Central Tracker", vbInformation
With Workbooks("Central Tracker - Live.xlsm").Worksheets("Data 2021")

Workbooks("Central Tracker - Live.xlsm").Worksheets("Data 2021").Activate
Set D = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlIp).Row)
    MsgBox "D Range Set", vbInformation
End With

    MsgBox "Starting URN Match", vbInformation
For Each cell In i
'Look for a URN match in column B on both sheets
If i.Value = K.Value Then
MsgBox "URN Match Found", vbInformation
Sheets("Data 2021").Cells(D, 1).Value = Sheets("Import Sheet").Cells(i, 1).Value 'copy and replace Column A Incident Process
Sheets("Data 2021").Cells(D, 6).Value = Sheets("Import Sheet").Cells(i, 6).Value 'copy and replace Column F Status
Sheets("Data 2021").Cells(D, 9).Value = Sheets("Import Sheet").Cells(i, 9).Value 'copy and replace Column I Title
Sheets("Data 2021").Cells(D, 10).Value = Sheets("Import Sheet").Cells(i, 10).Value 'copy and replace Column J Business Contact
Sheets("Data 2021").Cells(D, 11).Value = Sheets("Import Sheet").Cells(i, 11).Value 'copy and replace Column K Submitting Team
Sheets("Data 2021").Cells(D, 13).Value = Sheets("Import Sheet").Cells(i, 13).Value 'copy and replace Column M Marketing
Sheets("Data 2021").Cells(D, 14).Value = Sheets("Import Sheet").Cells(i, 14).Value 'copy and replace Column N Product
Sheets("Data 2021").Cells(D, 15).Value = Sheets("Import Sheet").Cells(i, 15).Value 'copy and replace Column O Project Name
Sheets("Data 2021").Cells(D, 16).Value = Sheets("Import Sheet").Cells(i, 16).Value 'copy and replace Column P CONC
Sheets("Data 2021").Cells(D, 17).Value = Sheets("Import Sheet").Cells(i, 17).Value 'copy and replace Column Q Date Email Receieved
Sheets("Data 2021").Cells(D, 18).Value = Sheets("Import Sheet").Cells(i, 18).Value 'copy and replace Column R Time Receieved
Sheets("Data 2021").Cells(D, 23).Value = Sheets("Import Sheet").Cells(i, 23).Value 'copy and replace Column W Checklist
Sheets("Data 2021").Cells(D, 24).Value = Sheets("Import Sheet").Cells(i, 24).Value 'copy and replace Column X Rejected
Sheets("Data 2021").Cells(D, 25).Value = Sheets("Import Sheet").Cells(i, 25).Value 'copy and replace Column Y Allocated To
Sheets("Data 2021").Cells(D, 26).Value = Sheets("Import Sheet").Cells(i, 26).Value 'copy and replace Column Z Allocation Reason
Sheets("Data 2021").Cells(D, 27).Value = Sheets("Import Sheet").Cells(i, 27).Value 'copy and replace Column AA Allocation Date
Sheets("Data 2021").Cells(D, 28).Value = Sheets("Import Sheet").Cells(i, 28).Value 'copy and replace Column AB Reallocation
Sheets("Data 2021").Cells(D, 29).Value = Sheets("Import Sheet").Cells(i, 29).Value 'copy and replace Column AC Reallocation Date
Sheets("Data 2021").Cells(D, 30).Value = Sheets("Import Sheet").Cells(i, 30).Value 'copy and replace Column AD Reallocation Reason
Sheets("Data 2021").Cells(D, 35).Value = Sheets("Import Sheet").Cells(i, 35).Value 'copy and replace Column AI Date Business emailed
Sheets("Data 2021").Cells(D, 36).Value = Sheets("Import Sheet").Cells(i, 36).Value 'copy and replace Column AJ Time business emaailed
Sheets("Data 2021").Cells(D, 37).Value = Sheets("Import Sheet").Cells(i, 37).Value 'copy and replace Column AK Date Matter Closed
Sheets("Data 2021").Cells(D, 38).Value = Sheets("Import Sheet").Cells(i, 38).Value 'copy and replace Column AL Comments
Sheets("Data 2021").Cells(D, 40).Value = Sheets("Import Sheet").Cells(i, 40).Value 'copy and replace Column AN CM Risk
Sheets("Data 2021").Cells(D, 45).Value = Sheets("Import Sheet").Cells(i, 45).Value 'copy and replace Column AS Date Modified
    MsgBox "Completed Copy and Paste - starting to clear old data from Import Sheet", vbInformation
Sheets("Import Sheet").Cells(i, 1).Clear
Else
    MsgBox "URN Does Not Match", vbInformation
Exit For
End If

Next
    MsgBox LoopIndex & "Loop Count", vbInformation

Sheets("Import Sheet").Activate
Columns("A:AN").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp

Sheets("Import Sheet").Protect "ImportSheet"
Sheets("Import Sheet").Visible = False
'Switch off automatic screen updating
Application.ScreenUpdating = True

    MsgBox "Good News! Your data has been transferred to the Central Tracker.", vbInformation

End Sub

已知错误点 #

• 常量拼写错误：代码中xlIp为笔误，VBA中向上查找最后一行的合法常量是xlUp，这是范围定义失败的最直接原因
• 变量未声明：K、cell、LoopIndex等变量均未定义，且模块开头未加Option Explicit强制校验变量声明，运行时会抛出变量未定义错误
• 范围对象使用错误：
  • 遍历i范围时直接调用i.Value（i是整列范围，无法直接读取值），且对比的K对象不存在，应该用循环变量cell的值到目标范围D中查找匹配项
  • 赋值时直接将范围对象D、i传入Cells()的行号参数，Cells()要求传入数字行号/列号，传入范围对象会直接报错
• 逻辑漏洞：当前匹配逻辑是只要遇到一个不匹配的URN就直接退出循环，会导致后续数据完全没有处理
• 冗余操作过多：大量Activate、Select操作不仅降低运行效率，还容易触发工作表上下文错误，可通过直接引用对象省略

修复后完整代码 #

Option Explicit ' 放在模块最开头，强制校验变量声明

Sub Compare_DataSheet2021_ImportSheet()
    Dim wbCentral As Workbook
    Dim wsImport As Worksheet, wsData As Worksheet
    Dim rngImport As Range, rngData As Range, cell As Range, matchRng As Range
    Dim lastRowImport As Long, lastRowData As Long
    
    Application.ScreenUpdating = False
    Set wsImport = ThisWorkbook.Worksheets("Import Sheet")
    
    ' 处理导入表权限
    wsImport.Visible = True
    wsImport.Unprotect "ImportSheet"
    
    ' 打开中央追踪表
    On Error Resume Next
    Set wbCentral = Workbooks.Open("Y:\GLOBAL\LEGAL\LCCTeam\Test Folder\Central Tracker - Live.xlsm")
    If Err.Number <> 0 Then
        MsgBox "中央追踪表打开失败，请检查路径是否正确", vbCritical
        GoTo Cleanup
    End If
    On Error GoTo 0
    
    If wbCentral.ReadOnly Then
        wbCentral.Close SaveChanges:=False
        MsgBox "Central Tracker is already in use. Speak to the Inbox Manager", vbExclamation
        GoTo Cleanup
    End If
    Set wsData = wbCentral.Worksheets("Data 2021")
    
    ' 正确定义两个表的URN范围
    lastRowImport = wsImport.Cells(wsImport.Rows.Count, "B").End(xlUp).Row
    Set rngImport = wsImport.Range("B2:B" & lastRowImport)
    
    lastRowData = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row
    Set rngData = wsData.Range("B2:B" & lastRowData)
    
    ' 匹配URN并赋值
    For Each cell In rngImport
        ' 查找当前URN在中央表是否存在
        Set matchRng = rngData.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not matchRng Is Nothing Then
            ' 匹配到则批量赋值
            wsData.Cells(matchRng.Row, 1).Value = wsImport.Cells(cell.Row, 1).Value
            wsData.Cells(matchRng.Row, 6).Value = wsImport.Cells(cell.Row, 6).Value
            wsData.Cells(matchRng.Row, 9).Value = wsImport.Cells(cell.Row, 9).Value
            wsData.Cells(matchRng.Row, 10).Value = wsImport.Cells(cell.Row, 10).Value
            wsData.Cells(matchRng.Row, 11).Value = wsImport.Cells(cell.Row, 11).Value
            wsData.Cells(matchRng.Row, 13).Value = wsImport.Cells(cell.Row, 13).Value
            wsData.Cells(matchRng.Row, 14).Value = wsImport.Cells(cell.Row, 14).Value
            wsData.Cells(matchRng.Row, 15).Value = wsImport.Cells(cell.Row, 15).Value
            wsData.Cells(matchRng.Row, 16).Value = wsImport.Cells(cell.Row, 16).Value
            wsData.Cells(matchRng.Row, 17).Value = wsImport.Cells(cell.Row, 17).Value
            wsData.Cells(matchRng.Row, 18).Value = wsImport.Cells(cell.Row, 18).Value
            wsData.Cells(matchRng.Row, 23).Value = wsImport.Cells(cell.Row, 23).Value
            wsData.Cells(matchRng.Row, 24).Value = wsImport.Cells(cell.Row, 24).Value
            wsData.Cells(matchRng.Row, 25).Value = wsImport.Cells(cell.Row, 25).Value
            wsData.Cells(matchRng.Row, 26).Value = wsImport.Cells(cell.Row, 26).Value
            wsData.Cells(matchRng.Row, 27).Value = wsImport.Cells(cell.Row, 27).Value
            wsData.Cells(matchRng.Row, 28).Value = wsImport.Cells(cell.Row, 28).Value
            wsData.Cells(matchRng.Row, 29).Value = wsImport.Cells(cell.Row, 29).Value
            wsData.Cells(matchRng.Row, 30).Value = wsImport.Cells(cell.Row, 30).Value
            wsData.Cells(matchRng.Row, 35).Value = wsImport.Cells(cell.Row, 35).Value
            wsData.Cells(matchRng.Row, 36).Value = wsImport.Cells(cell.Row, 36).Value
            wsData.Cells(matchRng.Row, 37).Value = wsImport.Cells(cell.Row, 37).Value
            wsData.Cells(matchRng.Row, 38).Value = wsImport.Cells(cell.Row, 38).Value
            wsData.Cells(matchRng.Row, 40).Value = wsImport.Cells(cell.Row, 40).Value
            wsData.Cells(matchRng.Row, 45).Value = wsImport.Cells(cell.Row, 45).Value
            ' 清空导入表对应行
            wsImport.Cells(cell.Row, 1).Clear
        End If
    Next
    
    ' 清理导入表空行
    On Error Resume Next ' 避免没有空行时报错
    wsImport.Range("A:AN").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    On Error GoTo 0
    
    ' 保存并关闭中央表
    wbCentral.Save
    wbCentral.Close SaveChanges:=False
    
Cleanup:
    ' 恢复导入表设置
    wsImport.Protect "ImportSheet"
    wsImport.Visible = False
    Application.ScreenUpdating = True
    MsgBox "处理完成，数据已同步至中央追踪表", vbInformation
End Sub

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