|
重複の2つ目以降に色を替え、Flagを立てれば善いのですね?
Option Explicit
Public Sub Repeated()
'変更するパレット番号
Const clngColor As Long = 3
'Flagを立てる列(Offset値)
Const clngCol As Long = 11
Dim i As Long
Dim dicIndex As Object
Dim vntData As Variant
Dim rngList As Range
Dim lngRows As Long
Application.ScreenUpdating = False
'List先頭セルを設定
Set rngList = ActiveSheet.Cells(2, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データを配列に読み込み
vntData = .Resize(lngRows).Value
End With
'Dictionaryオブジェクトのインスタンスを作成
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'データの先頭から最終まで繰り返し
For i = 1 To lngRows
'データが""で無い場合
If vntData(i, 1) <> "" Then
'インデックスにデータが有る場合(重複の場合)
If .Exists(vntData(i, 1)) Then
'重複行位置に就いて
With rngList.Offset(i - 1)
'重複行位置をパレット番号の色にする
.Interior.ColorIndex = clngColor
'L列に1を立てる
.Offset(, clngCol).Value = 1
End With
Else
'インデクスにKeyと行位置を追加
.Add vntData(i, 1), i
End If
End If
Next i
End With
Set dicIndex = Nothing
Set rngList = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
|
|