| |
もう見て居ないかな？
こんなのも有るよ
Option Explicit
Public Sub Repetition()
'データの列数(基準位置からの列数、この列の1列外側を作業列にします)
'例えば、基準セル位置がA列で、データがAB列まで有るなら
Const clngColumns As Long = 28
'重複を比較する列（基準列位置からの列Offset)
'例えば、基準セル位置がA列で、比較列がAB列なら
Const clngKeys As Long = 27
Dim i As Long
Dim lngRows As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntData As Variant
Dim dicIndex As Object
Dim lngFlags() As Long
Dim strProm As String
'データの左上隅を基準とする
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row, _
clngKeys).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'Keyを配列に取得
vntData = .Offset(, clngKeys).Resize(lngRows + 1).Value
End With
'Flagを格納する配列を確保
ReDim lngFlags(1 To lngRows, 1 To 1)
Application.ScreenUpdating = False
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'データ行数分繰り返し
For i = 1 To lngRows
'Keyの登録が有るなら（重複が有る)
If .Exists(vntData(i, 1)) Then
'削除フラグを立てる
lngFlags(i, 1) = 1
'削除数をカウント
lngCount = lngCount + 1
Else
'Keyの登録
.Add vntData(i, 1), Empty
End If
Next i
End With
Set dicIndex = Nothing
With rngList
'削除する行が合った場合
If lngCount > 0 Then
'削除フラグの配列をデータ列の右側に出力
.Offset(, clngColumns).Resize(lngRows).Value = lngFlags
'削除フラグの列をKeyとして整列
.Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
'行削除
.Offset(lngRows - lngCount) _
.Resize(lngCount).EntireRow.Delete
''削除フラグの列を消去
.Offset(, clngColumns).EntireColumn.ClearContents
strProm = lngCount & " 行の削除が完了しました"
Else
strProm = "重複行が有りません"
GoTo Wayout
End If
End With
Wayout:
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
