複数の項目が重複した古い方の列を削除

Question

引き継いだＶＢＡで悩んでいます。
初心者なので皆さんお助け下さい。

エクセル2010で動かしてします。
前日のデータに当日のデータを下の段に足します。
が更新されたデータには前日と同じデータが存在します。
今まではＥ列のみ重複の場合でよかったのですが、
今回Ｉ列も重複している場合に変更になりました。
Ｅ列とＩ列が同じなら古い上段を削除したいです。

RemoveDuplicatesを使うと新しいデータが削除されてしまうので、
前任者は下記のようにしたのだと思います。
下記ですとＩ列が違ってもＥ列が同じなら、削除されます。
条件にＥ列Ｉ列共に同じ場合古い方を列ごと削除するのは
どうすればいいのでしょうか？
どうかお助け下さい。

Sub DataDelete()
Dim i As Long, rng As Range, EndRow As Long
Dim Hani As Range

EndRow = Range("E" & Rows.Count).End(xlUp).Row
For i = EndRow To 2 Step -1
Set Hani = Range(Range("E2"), Range("I" & i - 1))
For Each rng In Hani
If rng.Value = Range("I" & i) Then
rng.Interior.ColorIndex = 3
End If
Next rng
Next i
For i = EndRow To 2 Step -1
If Range("I" & i).Interior.ColorIndex <> xlNone Then
Range("E" & i).EntireRow.Delete
End If
Next i
End Sub

Answer 1

上の方が残るなら、残したい方を上に持ってきては？

Sub test()
    Dim rngOld As Range     '前日のデータのセル範囲
    Dim rngNew As Range     '最新のデータのセル範囲

    Set rngOld = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion
    Set rngNew = Workbooks(2).Worksheets(1).Range("A1").CurrentRegion

    rngOld.Copy rngNew(rngNew.Rows.Count + 1, 1)

    rngNew.CurrentRegion _
            .AdvancedFilter Action:=xlFilterCopy, _
                            CopyToRange:=rngOld.Rows(1), _
                            Unique:=True
End Sub

Comments

[myunmomo]

mattuwanさん　ありがとうございました。

残したい方を上に持ってきてから削除してから、
日にち順にソートですよね。
すみません。
rngNew.CurrentRegion _
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=rngOld.Rows(1), _
Unique:=True

がうまく動きません。
newの下にoldが貼りつきましたが、その後はどう動くのでしょうか？

Answer 2

Ｅ列とＩ列が同じなら古い上段を削除したいです。

Dictionaryを使うとか、いろいろ方法は考えられますが、
現状のコードをなるべく活かすなら、下記のような感じでしょうか。

Sub DataDelete()
    Dim i As Long, rng As Range, EndRow As Long
    Dim Hani As Range

    EndRow = Range("E" & Rows.Count).End(xlUp).Row
    For i = EndRow To 3 Step -1
        Set Hani = Range(Range("E2"), Range("E" & i - 1))
        For Each rng In Hani
            If rng.Value = Range("E" & i) And rng.Offset(, 4).Value = Range("I" & i) Then
                rng.Interior.ColorIndex = 3
            End If
        Next rng
    Next i
    For i = EndRow To 2 Step -1
        If Range("E" & i).Interior.ColorIndex <> xlNone Then
            Range("E" & i).EntireRow.Delete
        End If
    Next i
End Sub

---

Dictionaryを使って重複チェックするコード例

Sub DataDelete2()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Dim EndRow As Long
    EndRow = Range("E" & Rows.Count).End(xlUp).Row
    
    Dim i As Long
    For i = EndRow To 2 Step -1
        If d.Exists(Cells(i, "E") & ";" & Cells(i, "I")) Then
             Range("E" & i).EntireRow.Delete
        Else
            d(Cells(i, "E") & ";" & Cells(i, "I")) = i
        End If
    Next i
End Sub

Comments

[myunmomo]

hatena19さん　ありがとうございます。

2行目と3行目にＥ列は重複しているが、Ｉ列は重複していないのに、
2行目の古い行が削除になりました。
どうしてでしょうか？

[hatena19]

コードに間違いがありましたので修正しました。
もういちどコピーしなおして試してみてください。

[myunmomo]

hatena19さん　ありがとうございます。

2行目3行目は解決いたしました。
誠に申し訳ありませんが、並び替え削除の前にセルに色を付けることは可能でしょうか？
削除の前に検証が必要になりました。
削除されてはいけない重複データが発生しました。

[hatena19]

前者のコードなら、後のループの部分を別にプロシージャに分割すれば、重複セルに色だけつきます。
削除てもいいかどうかをチェックしてから、よければ分割したプロシージャを実行すればいいでしょう。

後者のコードなら、EntireRow.Delete の部分を Interior.ColorIndex = 3 に変更すれば色がつきます。
削除は上記の分割したプロシージャを実行すればいいでしょう。

[myunmomo]

hatena19さん　ありがとうございます。
上手くいきました。
ありがとうございました。