Question

我正在使用以下Private Sub Worksheet_Change(ByVal Target As Range)（在paul bica的支持下创建）：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long, lrT3 As Long, inAV As Boolean

lr = Me.Rows.Count
lrT3 = Me.Range("A" & lr).End(xlUp).Offset(8).Row
inAV = Not Intersect(Target, Me.Range("AV9:AV" & lrT3)) Is Nothing


With Target

    'Exit Sub if pasting multiples values, Target is not in col AV, or is empty
    If .Cells.CountLarge > 1 Or Not inAV Then Exit Sub

    Application.EnableEvents = False
    If .Value = "Relevant" Or .Value = "For Discussion" Then
        Me.Cells(.Row, "A").Resize(, 57).Copy
        With Tabelle14.Range("A" & lr).End(xlUp).Offset(1)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            .PasteSpecial xlPasteColumnWidths
        End With

        Me.Cells(.Row, "A").Resize(, 2).Copy
        With Tabelle10
            .Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End With


    ElseIf .Value = "Not Relevant" Then
        Me.Cells(.Row, "A").Resize(, 2).Copy
        With Tabelle10
            .Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End With

    End If
    Application.CutCopyMode = False
    Application.EnableEvents = True
End With


'//Delete all duplicate rows
Tabelle10.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)

Tabelle14.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)


End Sub

1。挑战

因为状态可能会从Relevant更改为For Discussion，反之亦然。将有临时两个条目该公司的Tabelle14在最后一次被删除之前，由于Tabelle14.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)。但是我想保留最后一个条目并删除之前的条目，因为它包含更新的状态。有人知道如何调整我的代码来做到这一点或者可以暗示我正确的方向吗？

2。挑战

如果.Value = "Not Relevant"我想检查Tabelle14是否可以找到识别码（Tabelle3列A），如果是，则应在Tabelle14中删除该行。例如，如果在Tabelle3 Column AV Row 23状态设置为Not Relevant，我希望代码能够证明Tabelle3 Cell A23中的标识号是否也可以在Tabelle14 Column A中找到，如果识别号码在例如Tabelle14 Cell A 48我想删除整行。我的第一个想法是使用FIND，但到目前为止我还没有弄清楚如何将FIND与变量一起使用。如果有人暗示我会很高兴。 :)

Answer 1

尝试RemovePrevious() sub bellow

使用Find来查找以前的记录ID（在A列中）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lr As Long, lrT3 As Long, inAV As Boolean

    lr = Me.Rows.Count
    lrT3 = Me.Range("A" & lr).End(xlUp).Offset(8).Row
    inAV = Not Intersect(Target, Me.Range("AV9:AV" & lrT3)) Is Nothing

    With Target
        If .Cells.CountLarge > 1 Or Not inAV Then Exit Sub

        Application.EnableEvents = False
        If .Value = "Relevant" Or .Value = "For Discussion" Then
            Me.Cells(.Row, "A").Resize(, 57).Copy
            With Tabelle14.Range("A" & lr).End(xlUp).Offset(1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteColumnWidths
            End With
            Me.Cells(.Row, "A").Resize(, 2).Copy
            Tabelle10.Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        ElseIf .Value = "Not Relevant" Then
            RemovePrevious Me.Cells(.Row, "A")
            Me.Cells(.Row, "A").Resize(, 2).Copy
            With Tabelle10
                .Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            End With
        End If
        Application.CutCopyMode = False
        Application.EnableEvents = True
    End With
    Tabelle10.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)
    Tabelle14.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)
End Sub

Public Sub RemovePrevious(ByRef itm As Range)
    Dim ws As Worksheet, prev As Variant, cnt As Byte, v As String, r As Long

    Set ws = itm.Parent
    v = itm.Value
    r = itm.Row

    With ws.UsedRange.Columns(itm.Column)

        Set prev = .Find(What:=v, After:=ws.Cells(9, itm.Column), LookAt:=xlWhole, _
                         SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

        If Not prev Is Nothing Then
            While Not prev Is Nothing And prev.Row = r
                If Not prev Is Nothing And prev.Row = r Then Set prev = .FindNext(v)
            Wend
        End If

    End With

    If Not prev Is Nothing Then If prev.Row <> r Then prev.EntireRow.Delete
End Sub

使用RemoveDuplicates函数并保留最后一个条目

1 个答案: