重複確認

下記のVBAコードを実行したら画像の様な結果になります。
グループ２、３のように同じ時間がありますが片方が色がついてしまいます。
グループ２なら両方色つけグループ３も1:06が２つあるのでそちらも色付したのですがどうすればいいでしょうか？
どなたか詳しい方教えてください。
Sub 重複削除()
Dim ws As Worksheet
Dim iLastRow As Long
Dim dict As Object
Dim key As Variant
Dim i As Long
Dim maxRow As Long
Dim maxTime As Date

' Set the worksheet
Set ws = ThisWorkbook.Sheets("時系列") ' 必要に応じてシート名を変更してください

' Get the last row with data in column I
iLastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row

' Create a dictionary to store the latest time for each value in column I
Set dict = CreateObject("Scripting.Dictionary")

' Loop through column I to find duplicates and their latest time
For i = 2 To iLastRow ' Assuming there is a header row
If Not IsEmpty(ws.Cells(i, "I").Value) Then
key = ws.Cells(i, "I").Value
If dict.exists(key) Then
' Update the latest time if current time is newer
If ws.Cells(i, "E").Value > ws.Cells(dict(key), "E").Value Then
dict(key) = i
End If
Else
dict.Add key, i
End If
End If
Next i

' Highlight the rows with the latest time for each duplicate value
For Each key In dict.keys
maxRow = dict(key)
ws.Rows(maxRow).Interior.Color = RGB(255, 255, 0) ' Yellow color
Next key

' Clean up
Set dict = Nothing
End Sub

No.1 回答者： fujillin 回答日時： 2024/06/30 15:21

こんにちは

シートに関しての説明やなさりたいことの説明も曖昧なので、イマイチはっきりとはしませんけれど・・・
（ご提示の図では、Ｅ列とＩ列が隣接しているようなので、セルを結合しているのかどうかもよくわかりませんし・・）

とりあえず以下のように仮定して解釈しました。
・Ｉ列にグループ名が記入されている。
・Ｅ列に日時がシリアル値で記入されている。
・1行目はタイトル行で処理対象外としてよい。

なさりたいことは
『同じグループ名の行のうち、日付が最も大きい（＝最新の）行全てに背景色を付けたい』
と解釈しました。
※ ご提示の日時は「分」までの表示しかありませんけれど、秒数迄を含めて判断してよいものと解釈します。
（見かけ上同じ分数でも、秒数が異なれば異なる時刻と判断する）


＞そちらも色付したのですがどうすればいいでしょうか？
ご提示のコードではDictionaryオブジェクトを利用して、グループ名毎の最大日時の行番号を記録する方式になっています。
現状では、
＞If ws.Cells(i, "E").Value > ws.Cells(dict(key), "E").Value Then
で、記録したものより大きな時刻が出現した時のみ行番号を入れ替えるようになっていますが、複数存在する可能性を考慮するなら、イコールの場合には記録に追加するようにしておけば宜しいでしょう。

ただし、Dictionaryは key, value形式の記録なので、複数の値を記録するには、value値を工夫する必要があります。
例えば、カンマ区切りの文字列として記録するようにするとか。
あるいは、セル配列を記憶する方法もありそうに思いますが、value値がオブジェクトを許容していたかどうか記憶していませんので、こちらは確認の上ご利用ください。


一方で、ご提示のことをなさりたいのであれば、シートに「条件付き書式」を設定しておけば、いちいちマクロを実行する必要もなく、値が変化すればその内容に応じて背景色が変わるようにできると思います。
エクセルの利用法としては、これが一般的と言えるでしょう。
（Office365であれば、MAXIFS関数が使えるので簡単に設定できます）
また、ご提示のコードでは背景色をクリアしてはいないようなので、値を変更して再度実行するだけでは、必ずしも正しい結果ではない可能性が生じます。
その点でも、条件付き書式であれば、状態に応じて常に判断してくれますので、値を変更すれば即時に結果に反映されます。


方法は全く異なりますが、エクセルに計算してもらう方法を以下ご参考までに。
（処理内容は、最初に示した内容として解釈しています）
（最終列を作業列として利用しています）

Sub Q13853633()
Dim rg As Range, c As Range
Dim maxR As Long
Const f = "=(I2<>"""")*(AGGREGATE(14,6,E$2:E$@/(I$2:I$@=I2),1)=E2)"

With ThisWorkbook.Worksheets("時系列")
maxR = .Cells(Rows.Count, 9).End(xlUp).Row
If maxR < 2 Then Exit Sub
Set rg = .Cells(2, Columns.Count).Resize(maxR - 1)
rg.Formula = Replace(f, "@", maxR)
rg.EntireRow.Interior.Color = xlNone
For Each c In rg
If c.Value Then c.EntireRow.Interior.Color = vbYellow
Next c
rg.ClearContents
End With
End Sub

この回答へのお礼

回答ありがとうございます。
・セルの結合に関してですが画像をわかりやすくするため非表示にしていますので結合はしていません。
・やりたいことはご提示くださった日時は「分」まで判断し秒数が違っても同じにしたい。
・確かにkeyを使うマクロは作成中にネットで検索したときに見て試しましたが使い方が悪くうまくいきませんでした。

またエクセルのご提示ありがとうございます。最終的にやりたいことは色が付いていない行を消しすところまでやりたのですがその作成がうまくいかないのでまず色付けの条件でネットから検索してマクロを作成してうまくいけば色が付いて無い行を消すマクロを追加すればいいかと思い作成中です。

お礼日時：2024/06/30 17:03