bugfix> excel > 投稿

私は次の 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 へまたはその逆。一時的な2つのエントリがあります    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 の使い方を理解していません変数付き。誰かが私のためのヒントを持っているなら幸せでしょう。 :)

回答 1 件
  • RemovePrevious() を試す  サブベローズ

    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
    
    

あなたの答え