工作簿工作表变更：复制行

• 将以下代码复制到ThisWorkbook模块中。

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim Success As Boolean
    On Error GoTo ClearError

    Const CRITERIA_COLUMN As Long = 26
    
    Dim wsNames(): wsNames = VBA.Array("Complete", "Outstanding")
    Dim FirstRows(): FirstRows = VBA.Array("A2:Z2", "A2:Z2")
    Dim Criteria(): Criteria = VBA.Array("Outstanding", "Complete")
    
    Dim aIndex: aIndex = Application.Match(Sh.Name, wsNames, 0)
    If IsError(aIndex) Then Exit Sub
    
    aIndex = aIndex - 1
    Dim sws As Worksheet: Set sws = Me.Sheets(wsNames(aIndex))
    
    Dim srg As Range
    With sws.Range(FirstRows(aIndex))
        Set srg = .Resize(sws.Rows.Count - .Row + 1)
    End With
    
    Dim irg As Range: Set irg = Intersect(srg.Columns(CRITERIA_COLUMN), Target)
    If irg Is Nothing Then Exit Sub
    
    Dim urg As Range, cel As Range
    
    For Each cel In irg.Cells
        If StrComp(CStr(cel.Value), Criteria(aIndex), vbTextCompare) = 0 Then
            If urg Is Nothing Then Set urg = cel Else Set urg = Union(urg, cel)
        End If
    Next cel
    
    If urg Is Nothing Then Exit Sub

    aIndex = (aIndex + 1) Mod 2
    
    Dim dws As Worksheet: Set dws = Me.Sheets(wsNames(aIndex))
    If dws.FilterMode Then dws.ShowAllData
    
    Dim dfCell As Range
    
    With dws.Range(FirstRows(aIndex))
        Dim dlCell As Range: Set dlCell = .Resize(dws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If dlCell Is Nothing Then
            Set dfCell = .Cells(1)
        Else
            Set dfCell = .Cells(1).Offset(dlCell.Row - .Row + 1)
        End If
    End With
     
    Application.EnableEvents = False
    
    With Intersect(srg, urg.EntireRow)
        .Copy dfCell
        .Delete xlShiftUp
    End With
    
    Success = True
    
ProcExit:
    If Not Application.EnableEvents Then Application.EnableEvents = True
    If Not Success Then MsgBox "Something went wrong.", vbCritical
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit
End Sub

我做过这个测试。
1.在通用模块Module1中，我们创建子例程DoWorksheet_Change()，使用ActiveSheet来标识我们正在编辑的工作表。

'Remove Case Sensitivity
Option Compare Text
Option Explicit

Sub DoWorksheet_Change(ByVal Target As Range)
    ' On Error Resume Next - I took this out of this code that I found on the internet because it apparently causes problems
      
    Dim LrowCompleted As Long
      
    Application.EnableEvents = False
    
    'Debug.Print ActiveSheet.Name
    'If Cell that is edited is in column Z and the value is Complete then
    If Target.Column = 26 And Target.Cells(1).Value = "Complete" Then
        'Define last row on Complete worksheet to know where to place the row of data
        LrowCompleted = Sheets("Complete").Cells(Rows.Count, "A").End(xlUp).Row
        'Copy and paste data
        ActiveSheet.Range("A" & Target.Row & ":Z" & Target.Row).Copy Sheets("Complete").Range("A" & LrowCompleted + 1)
        'Delete Row from the ActiveSheet
        ActiveSheet.Range("A" & Target.Row & ":Z" & Target.Row).Delete xlShiftUp
    ElseIf Target.Column = 26 And Target.Cells(1).Value = "Outstanding" Then
        'Define last row on Outstanding worksheet to know where to place the row of data
        LrowCompleted = Sheets("Outstanding").Cells(Rows.Count, "A").End(xlUp).Row
        'Copy and paste data
        ActiveSheet.Range("A" & Target.Row & ":Z" & Target.Row).Copy Sheets("Outstanding").Range("A" & LrowCompleted + 1)
        'Delete Row from the ActiveSheet
        ActiveSheet.Range("A" & Target.Row & ":Z" & Target.Row).Delete xlShiftUp

    End If
     
    'Debug.Print ActiveSheet.Name
    
    Application.EnableEvents = True
End Sub

1.在Outstanding和Complete表单私有模块中，我们放置相同的代码，调用公共宏DoWorksheet_Change()。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  DoWorksheet_Change Target
End Sub