エクセルで不要な行を自動で削除する

質問

エクセルを使った表で下記の様なデータがあります。
A列は番号、B列は来歴で、一番最後の文字(A0000の場合はB)の行が最新のデータになります。
例えばA0000の場合は始めのデータは「スニーカー」「サンダル」でしたが、Ａ改定で「パンプス」が加わり、
更にＢ改定で「スニーカー」と「パンプス」が無くなったので、最終のデータは「サンダル」だけになります。
自動でこの表を結果の様に、夫々の番号で最終の来歴だけを残す方法を教えて下さい。
行は4000行程あり、来歴は無しの物からJ位まであります。
又番号によってデータの行数も異なります。Ｄ列以降にもデータは入っています。
　　　　A　　　　B　　　　C　　　　D　　　E
1　　A0000　　-　　スニーカー
2　　A0000　　-　　サンダル
3　　A0000　　A　　スニーカー
4　　A0000　　A　　サンダル
5　　A0000　　A　　パンプス
6　　A0000　　B　　サンダル
7　　B0000　　-　　Tシャツ
8　　C0000　　-　　スーツ
9　　C0000　　A　　スーツ
10　　C0000　　A　　ドレス
11　　C0000　　A　　着物
12　　D0000　　-　　靴下
13　　D0000　　-　　ストッキング
　　：
　　：

結果(最終来歴だけのデータにする)
　　　　A　　　　B　　　　C　　　　D　　　E
1　　A0000　　B　　サンダル
2　　B0000　　-　　Tシャツ
3　　C0000　　A　　スーツ
4　　C0000　　A　　ドレス
5　　C0000　　A　　着物
6　　D0000　　-　　靴下
7　　D0000　　-　　ストッキング

現在並び替えて手作業で削除していますので、是非良い知恵をご教授下さい。

回答No.4

myRange · ベストアンサー

作業列を使わないでやる方法。

先ず、質問提示のサンプルでテストしてください。
　　見出し：１行目
　　データ：２行目以降
としてあります。

また、実際のデータで実行する場合は
当然ながらそれに応じてテーブル範囲など適宜修正のこと。

'--------------------------------------------------
Sub Test()
　Dim myDic1, myDic2
　Dim Akey1, Akey2
　Dim Target As Range
　Dim R As Long
　Dim LastRow As Long

　Set myDic1 = CreateObject("Scripting.Dictionary")
　Set myDic2 = CreateObject("Scripting.dictionary")

　LastRow = Cells(Rows.Count, "A").End(xlUp).Row

'▲▲必要ならソートのコードをここに挿入

　For R = LastRow To 2 Step -1
　　　Akey1 = Cells(R, "A").Value
　　　Akey2 = Cells(R, "A").Value & "@" & Cells(R, "B").Value
　　　If myDic1.exists(Akey1) = False Then
　　　　　myDic1.Add Akey1, ""
　　　　　myDic2.Add Akey2, ""
　　　Else
　　　　　If myDic2.exists(Akey2) = False Then
　　　　　　　If Target Is Nothing Then
　　　　　　　　　Set Target = Cells(R, "A")
　　　　　　　Else
　　　　　　　　　Set Target = Union(Target, Cells(R, "A"))
　　　　　　　End If
　　　　　End If
　　　End If
　Next R

　Target.EntireRow.Delete xlUp

End Sub
'------------------------------------------------------

第１キー（Ａ列）第２キー（Ｂ列）のソートが必要なら、
上記▲のところに、下記ソートコードを挿入すること。

'--------------------------------------------------
　Range("A1:C" & LastRow).Sort _
　　　　Key1:=Range("A2"), Order1:=xlAscending, _
　　　　Key2:=Range("B2"), Order2:=xlAscending, _
　　　　Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin
'-------------------------------------------------------

以上です。

お礼

ご回答ありがとうございました。
完璧です。やりたいそのままの事が実現出来ました。
本当にありがとうございました。