Use RemoveDuplicates Function And Keep Last Entry

2019-09-03 13:15发布

问题:

I'm using following Private Sub Worksheet_Change(ByVal Target As Range) (created with support from 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. Challenge

As it can occur that the status is changed from Relevant to For Discussion or vice versa. There would be temporary two entries in Tabelle14for this company before the last one is deleted again, due to the Tabelle14.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2). However I would like to keep the last entry and delete the earlier instead, because it contains the updated status. Does someone know how I have to adjust my code to do this or can hint me the right direction?

2. Challenge

If .Value = "Not Relevant" I want to check Tabelle14 if the identification code (Tabelle3 column A) can there be found as well and if yes the row should be deleted in Tabelle14. For example, if in Tabelle3 Column AV Row 23 the status is set to Not RelevantI want the code to prove if the identification number in Tabelle3 Cell A23 can be found in Tabelle14 Column A as well and if the identifaction number is found in e.g. Tabelle14 Cell A 48 I want to delete the whole row. My first thought was to use FIND but I haven't figured out so far how to use FIND with a variable. Would be happy if someone has a hint for me. :)

回答1:

Try the RemovePrevious() sub bellow

It uses Find to to look for previous record ID (in column 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