【VBA】優先度を判定し重複行の削除をしたい

Question

実現したいこと

CA列に重複がある場合、優先度判定を行い、優先度の低い重複行をすべて削除したい。
データは６千行ほどあり、VBAで処理したいです。
CB列は文字列（1.***** 2.*****）となっており、左から先頭一文字目が1~7の数字となるのでまずこれを抽出する。

優先度の判定
・CB列の数字が小さい行を優先する
・CB列の数字が同じ場合、A列の数字が大きい行を優先する

行番号　CA列　CB列
１　　　x　　　1
２　　　y　　　4
３　　　x　　　3
４　　　y　　　4
５　　　z　　　6
６　　　x　　　2

例えば上記の例だと、
行番号１・３・６がCA列重複→CB列の優先度１が最も高いので３・６行目は削除
行番号２・４がCA列重複→CB列の優先度は同じ→A列の優先度４が高いので２行目は削除
行番号５は重複なしなので残す

発生している問題・分からないこと

辞書機能を使って既存の行と現在の行での比較（２行分の比較）しかできず、どうやっても
３行以上の比較が分からなかったので質問しました。

該当のソースコード

特になし

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

Googleでは優先度を判定する重複行削除の例が見つかりませんでした。

補足

特になし

Comments

[meg_]

> 辞書機能を使って既存の行と現在の行での比較（２行分の比較）しかできず、どうやっても３行以上の比較が分からなかったので質問しました。
どういうコードを書いたのでしょうか？

[hatena19]

エクセルのバージョンは何でしょうか。
それによって使える関数や機能が異なりますので。

[tatsu99]

>行番号２・４がCA列重複→CB列の優先度は同じ→A列の優先度４が高いので２行目は削除
提示された例では、A列の情報はありませんが、「A列の優先度４」は、どのようにしてわかるのでしょうか。

[yosy]

hatena19様
こちらになります。
Microsoft® Excel® for Microsoft 365 MSO (バージョン 2408 ビルド 16.0.17928.20114) 64 ビット
VBAでの処理をしたいと思っています。

[yosy]

tatsu99様
A列はシンプルに数字ですので、1~6000の番号が入っております。
提示漏れ申し訳ありません。

[yosy]

meg_様
当初はBX列に契約番号が入っているかいないかで優先度を決めていたので
現在の要望とは少し違いますが、下記のように記述しておりました。
全くの初心者で、契約番号がどちらも入っている場合などの考慮ができておらずお恥ずかしいです。。

' 重複チェックと優先順位による行の削除
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

' CA列の重複をチェックし、行番号を保存
For i = lastRow2 To 2 Step -1
cellValue = ws2.Cells(i, "CA").Value
If cellValue <> "" Then
If Not dict.exists(cellValue) Then
dict.Add cellValue, i
Else
' 優先順位の決定
Dim existingRow As Long
existingRow = dict(cellValue)

If ws2.Cells(i, "BX").Value <> "" And ws2.Cells(existingRow, "BX").Value = "" Then
' 既存の行に契約番号がない場合、既存の行を削除
ws2.Rows(existingRow).Delete
dict(cellValue) = i ' 現在の行を辞書に保存
ElseIf ws2.Cells(i, "BX").Value = "" And ws2.Cells(existingRow, "BX").Value <> "" Then
' 現在の行に契約番号がない場合、現在の行を削除
ws2.Rows(i).Delete
Else
' 他の場合は比較し、A列の数字が大きい方を残す
If ws2.Cells(i, "A").Value > ws2.Cells(existingRow, "A").Value Then
ws2.Rows(existingRow).Delete
dict(cellValue) = i ' 新しい行を辞書に保存
Else
ws2.Rows(i).Delete
End If
End If
End If
End If
Next i

Answer 1

これだめだな多分。3 で破綻だな。ソート列の値がソートで入れ替える都度変わってしまいそう。
もう一つの列に ０，１を入れる というのが式でできれば良いけど。。。
あ！
もう一つの列にその列の値をpastで良いか
以下駄目な案晒しておきます
ーーーーーーーーーーーーーーーーーーーー
一回ポッキリなら全部手作業でできるんじゃないかな。

1 CA, CB, A(逆順) でソートする
2 空いている列に式 上の行のCAとこの行のCAが等しかったら１違ってたら０
3 その列でソート
4 その列が１である先頭行を見つけ、そこから下を削除
5 その列を削除
6 Aでソート
7 Aをリナンバー

これが 一番早く答えが得られるような気がする

Comments

[yosy]

色々と考えていただきありがとうございます！
1回ぽっきりなら手作業でもちろん済ませるのですが、週に3回作業がありまして、
膨大な量なので今回ＶＢＡにチャレンジしてみた次第です。。。
情報記載出来ておらず申し訳ございません。

[winterboum]

週3回！
でしたら 私の最初の回答で、sortもVBAでやるのが簡明かと。

Answer 2

優先度の判定
・CB列の数字が小さい行を優先する
・CB列の数字が同じ場合、A列の数字が大きい行を優先する

CB列の先頭一文字×10000－A列の値　を比較するようにすればいいでしょう(A列の値が4桁以内の場合、桁数が多い場合はそれに合わせて×数値を増やします)。

辞書機能を使って既存の行と現在の行での比較（２行分の比較）しかできず、どうやっても
３行以上の比較が分からなかったので質問しました。

３行以上の比較をする必要はないのでは。
最終行から上に移動しながら、
辞書のキーにCA列の値、アイテムに行番号を登録していく、
CA列の値がキーにすでに存在する場合は、アイテムの行と現行の上記の比較値を比べて、比較値が大きいほうの行を削除して、小さいほうの行番号をアイテムに格納する。
これを先頭行まで繰り返せば、比較値の最小の行のみ残ります。
これで希望の結果に得られます。

訂正

上記のロジックですが、行番号を格納してそれを元に削除すると、削除することによってそれ以降の行が上に移動するので、格納した行番号とずれてしまいます。
実際にコード化して気が付きました。
ということで、下記のロジックに訂正します。

最終行から上に移動しながら、
辞書のキーにCA列の値、アイテムに比較値を登録していく、
CA列の値がキーにすでに存在する場合は、小さいほうの比較値をアイテムに格納する。
これを先頭行まで繰り返すとキーに対応する優先度のもっとも高い比較値が格納されます。

再度、最終行から上に移動しながら、
現在行の比較値と辞書の比較値(もっとも優先度の高い値)が一致しない行を削除する。
これを先頭行まで繰り返すと優先度の高い行のみ残る。

上記をコード化したコードが下記になります。

Public Sub Sample()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim tbl As Range
    Set tbl = Worksheets(1).Cells(1, 1).CurrentRegion
    
    Dim i As Long
    For i = tbl.Rows.Count To 2 Step -1
        Dim ky As String, pv As Long
        ky = tbl.Cells(i, "C").Text
        pv = Left(tbl.Cells(i, "D"), 1) * 10000 - tbl.Cells(i, "A")
        If dic.Exists(ky) Then
            If dic(ky) > pv Then
                dic(ky) = pv
            End If
        Else
            dic(ky) = pv
        End If
    Next
    
    For i = tbl.Rows.Count To 2 Step -1
       ky = tbl.Cells(i, "C").Text
       pv = Left(tbl.Cells(i, "D"), 1) * 10000 - tbl.Cells(i, "A")
       If dic(ky) <> pv Then
            tbl.Rows(i).Delete
       End If
    Next
End Sub

別案　式とフィルターを利用して手作業で

表範囲の右隣の空列の1行目に「比較値」と入力。
2行目に下記の式を設定する。
=LEFT(CB2,1)*10000-A2
フィルハンドルをダブルクリックすると最終行まで比較値が表示される

さらに右隣の列の1行目に「優先行」と入力。
2行目に下記の式を設定
`=MINIFS(CC$2:CC$6000,CA$2:CA$6000,CA2)=CC2
※CC は比較値の式を設定した列アドレス
フィルハンドルをダブルクリックすると最小比較値と一致する行はTRUE、不一致の行はFALSEとなる。

「優先行」列でフィルターをかけてFALSEの行を抽出する。
表示されている行を行削除する。
フィルターを解除する。
作業列2列を削除する。

以上。

Comments

[tatsu99]

>CB列の数字が同じ場合、A列の数字が大きい行を優先する
ということなので、
CB列の先頭一文字×10000+A列の値　を比較する
のではなく
CB列の先頭一文字×10000－A列の値　を比較する
のが正しいのではないでしょうか。

[hatena19]

> CB列の先頭一文字×10000－A列の値　を比較する
> のが正しいのではないでしょうか。

どちらも小さいときと誤読してました。
ご指摘ありがとうございます。
回答の方は修正しておきます。

[yosy]

hatena19様

提示していただいたコードの、下記部分だけ修正したら思い通りの結果になりました…！！！
pv = Val(Left(tbl.Cells(i, "C"), 1)) * 10000 - tbl.Cells(i, "A")
比較値の考え方などとても参考になりました。
本当にありがとうございました！

Answer 3

目的から見て一回しか通さないプログラムだと思われます。でしたらすべてをVBAにやらせるのではなく、前処理を手で行い、後処理も手で行えばスッキリしたcodeになると思います。「CBの先頭文字を抜き出す」処理も要らないし、 辞書などと大物を持ち出さなくても済みます。辞書検索もなくなるから処理も早くなるかなぁ。。
前処理も後処理もソートですのでそれもVBAで行っても良いですが。

前処理
CA, CB, A(逆順) でソートする

処理
下から2行づつ CA を比較し
・同じだったら下の行を削除。
・違ったら下の行を残し、新しい CA に移る

後処理
A でソート(必要なら)
Aの番号の付け直し(必要なら)