| |
Dictionayを使うとこんなかな？
列見出しが有る物とします
データは、A列〜B列の2列とし､重複を見るKeyは､A列に有るとします
C列を作業列として使用します
Option Explicit
Public Sub Sample_2()
'元々のデータ列数（A列〜B列）
Const clngColumns As Long = 2
'Keyの有る列(A列のA列からの列Offset)
Const clngKey As Long = 0
Dim i As Long
Dim lngRows As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntKeys As Variant
Dim lngDelete() As Long
Dim dicIndex As Object
Dim strProm As String
'Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'A列データを配列に取得
vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
End With
'削除Flagを格納する配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
For i = 1 To lngRows
'Dyctionaryに登録が有る場合
If .Exists(vntKeys(i, 1)) Then
'削除Flagを立てる
lngDelete(i, 1) = 1
'削除行数をカウント
lngCount = lngCount + 1
Else
'Dyctionaryに登録
.Item(vntKeys(i, 1)) = Empty
End If
Next i
End With
Set dicIndex = Nothing
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'削除行が有った場合
If lngCount > 0 Then
'削除Flagをを出力
.Offset(1, clngColumns).Resize(lngRows).Value = lngDelete
'削除FlagをKeyとしてListを整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'不用行を削除
.Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
strProm = lngCount & "行を削除しました"
Else
strProm = "重複行は在りません"
End If
'復帰用Key列を削除
.Offset(, clngColumns).Resize(, 2).EntireColumn.Delete
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/10/3(日) 15:43 -
