| |
みなさんこんにちは
半分遊びというか、こんな発想は受け入れられるのか？
というコードなのですがどうでしょうか？
1900/1/1〜2079/6/5の期間限定で日付のシリアル値をRowとして
Rangeに格納後Intersectで重複判定してみました。
発想の転換で楽しくコード勉強中です。
Sub test()
'####### 1900/1/1〜2079/6/5の期間限定 #######
'日付のシリアル値をRowとしてRangeに格納後Intersectで重複判定
Dim myDic As Object, i As Long, j As Long
Dim dat As Variant, key_name As Variant, item_row As Variant
Dim myRng As Range, chk_Rng As Range
Dim key_row() As String, hit_name As String
Cells.Interior.ColorIndex = xlNone
dat = Range("A2", Range("D65536").End(xlUp)).Value
Set myDic = CreateObject("Scripting.Dictionary")
j = 0
ReDim key_row(j)
For i = 1 To UBound(dat)
If Not myDic.exists(dat(i, 1)) Then
j = j + 1
myDic.Add dat(i, 1), j
ReDim Preserve key_row(j)
key_row(j) = i
Else
key_row(myDic.Item(dat(i, 1))) = _
key_row(myDic.Item(dat(i, 1))) & "," & i
End If
Next i
key_name = myDic.keys
For i = 0 To UBound(key_name)
item_row = Split(key_row(i + 1), ",")
If UBound(item_row) > 0 Then
Set myRng = Range(Cells(CLng(dat(item_row(0), 3)), 1), _
Cells(CLng(dat(item_row(0), 4)), 1))
For j = 1 To UBound(item_row)
Set chk_Rng = Range(Cells(CLng(dat(item_row(j), 3)), 1), _
Cells(CLng(dat(item_row(j), 4)), 1))
If Not Application.Intersect(myRng, chk_Rng) Is Nothing Then
Cells(item_row(j) + 1, 1).Resize(, 4).Interior.ColorIndex = 6
hit_name = hit_name & vbLf & key_name(i)
End If
Set myRng = Union(myRng, chk_Rng)
Next j
End If
Next i
MsgBox "重複者リスト" & vbLf & hit_name
Set myDic = Nothing
Set myRng = Nothing
Set chk_Rng = Nothing
End Sub
|
|
Lindy
- 07/8/23(木) 10:24 -
