Excel VBA批量处理库存出入库签核触发宏需求

问题背景 #

用户通过InputOutput Log工作表中的InputOutput列表对象管理库存，核心操作逻辑如下：

• 入库：填写A-D列信息后，在E列（第5列）完成签核，触发宏将当前行C-D列内容同步到Rack1或Rack2工作表的对应匹配行
• 出库：在F列（第6列）完成签核，触发宏清除Rack1/Rack2对应位置的内容

现有Worksheet_Change事件代码仅支持单行操作，无法处理批量填充E/F列（如一次性签核10条出入库记录）的场景，需要优化代码实现批量逐行处理所有变更行。

现有代码（仅支持单行操作） #

Private Sub Worksheet_Change(ByVal Target As Range)
Dim InOutTbl As ListObject: Set InOutTbl = ListObjects("InputOutput")
Dim InByRng As Range: Set InByRng = InOutTbl.ListColumns(5).DataBodyRange
Dim OutByRng As Range: Set OutByRng = InOutTbl.ListColumns(6).DataBodyRange
Dim MtchSheet As Worksheet, VialPos As String, MtchTbl As ListObject, MtchVialPos As Range, CopyRng As Range, PasteRng As Range
Set MtchSheet = ThisWorkbook.Sheets(Left(InOutTbl.Range(Target.Row, 1), 5))
VialPos = InOutTbl.Range(Target.Row, 2).Value
Set MtchTbl = MtchSheet.ListObjects(InOutTbl.Range(Target.Row, 1).Value)
Set MtchVialPos = MtchSheet.Cells.Find(What:=VialPos, after:=MtchTbl.HeaderRowRange(1), LookIn:=xlValues)
Set CopyRng = Range("C" & Target.Row & ":D" & Target.Row)
Set PasteRng = MtchSheet.Range("B" & MtchVialPos.Row & ":C" & MtchVialPos.Row)
If Not Application.Intersect(InByRng, Range(Target.Address)) Is Nothing Then
    CopyRng.Copy
    PasteRng.PasteSpecial xlPasteValues
ElseIf Not Application.Intersect(OutByRng, Range(Target.Address)) Is Nothing Then
    PasteRng.ClearContents
End If
End Sub

优化后的批量处理代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim InOutTbl As ListObject
    Dim InByCol As ListColumn, OutByCol As ListColumn
    Dim affectedRows As Range, cell As Range
    Dim tblRow As ListRow
    Dim mtchSheet As Worksheet
    Dim vialPos As String
    Dim mtchVialPos As Range
    Dim copyRng As Range, pasteRng As Range
    Dim rackName As String
    
    ' 关闭事件防止递归触发
    Application.EnableEvents = False
    On Error GoTo Cleanup ' 确保出错时恢复事件状态
    
    Set InOutTbl = Me.ListObjects("InputOutput")
    Set InByCol = InOutTbl.ListColumns(5) ' E列：入库签核列
    Set OutByCol = InOutTbl.ListColumns(6) ' F列：出库签核列
    
    ' 筛选出落在入库/出库签核列的变更单元格
    Set affectedRows = Application.Intersect(Target, Union(InByCol.DataBodyRange, OutByCol.DataBodyRange))
    If affectedRows Is Nothing Then GoTo Cleanup
    
    ' 遍历每个变更单元格，逐行处理
    For Each cell In affectedRows
        ' 获取当前单元格对应的列表行（避免行号偏移问题）
        Set tblRow = InOutTbl.ListRows(cell.Row - InOutTbl.HeaderRowRange.Row + 1)
        
        ' 提取货架名称（A列前5个字符）
        rackName = Left(tblRow.Range(1).Value, 5)
        ' 校验目标工作表是否存在
        On Error Resume Next
        Set mtchSheet = ThisWorkbook.Sheets(rackName)
        On Error GoTo Cleanup
        If mtchSheet Is Nothing Then GoTo NextCell
        
        ' 获取样品位置（B列值），空值跳过
        vialPos = tblRow.Range(2).Value
        If vialPos = "" Then GoTo NextCell
        
        ' 在目标工作表精准查找样品位置
        Set mtchVialPos = mtchSheet.Cells.Find(What:=vialPos, LookIn:=xlValues, LookAt:=xlWhole)
        If mtchVialPos Is Nothing Then GoTo NextCell
        
        ' 定义数据范围
        Set copyRng = tblRow.Range(3).Resize(1, 2) ' 当前行C-D列
        Set pasteRng = mtchSheet.Range("B" & mtchVialPos.Row).Resize(1, 2) ' 目标行B-C列
        
        ' 执行入库/出库操作
        If Not Application.Intersect(cell, InByCol.DataBodyRange) Is Nothing Then
            ' 入库：直接赋值替代粘贴，提升效率
            pasteRng.Value = copyRng.Value
        ElseIf Not Application.Intersect(cell, OutByCol.DataBodyRange) Is Nothing Then
            ' 出库：清除目标位置内容
            pasteRng.ClearContents
        End If
        
NextCell:
        ' 重置对象，避免内存泄漏
        Set mtchSheet = Nothing
        Set mtchVialPos = Nothing
    Next cell

Cleanup:
    ' 恢复事件状态，避免后续操作失效
    Application.EnableEvents = True
    ' 错误提示
    If Err.Number <> 0 Then
        MsgBox "处理出错：" & Err.Description, vbExclamation
        Err.Clear
    End If
End Sub

关键优化说明 #

• 批量处理支持：通过Union和Intersect筛选所有E/F列的变更单元格，遍历每个单元格对应的列表行，实现批量签核的逐行处理
• 防递归机制：操作前关闭Application.EnableEvents，避免复制/清除操作再次触发Worksheet_Change事件，通过错误处理确保事件状态必恢复
• 可靠的行定位：使用ListRow对象定位行，避免因列表插入/删除行导致的行号偏移问题
• 错误防护：添加工作表存在性、样品位置非空、查找结果有效性检查，避免空对象引发运行时错误
• 性能优化：直接用Value赋值替代Copy/PasteSpecial，减少剪贴板操作，提升运行效率

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