Используйте функцию RemoveDuplicates и сохраните последнюю запись

Question

Я использую следующее Private Sub Worksheet_Change(ByVal Target As Range) (созданное при поддержке Пола Бика):

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, может ли там также быть найден идентификационный код (столбец A таблицы Tabelle3) и если да, строка должна быть удалена в Tabelle14.Например, если в Tabelle3 Column AV Row 23 установлен статус Not Relevant, я хочу, чтобы код доказывал, можно ли найти также идентификационный номер в Tabelle3 Cell A23 в Tabelle14 Column A и если идентификационный номер находится, например, в Tabelle14 Cell A 48 Я хочу удалить всю строку.Моей первой мыслью было использовать FIND, но я пока не понял, как использовать FIND с переменной.Был бы счастлив, если бы у кого-то была подсказка для меня.:)

Answer 1

Попробуйте RemovePrevious() подпункт ниже

Он использует Find для поиска идентификатора предыдущей записи (в столбце 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