|
列見出しが有る物とします
データは、A列〜B列の2列とし、重複を見るKeyは、A列に有るとします
C列を作業列として使用します
Option Explicit
Public Sub Sample()
'元々のデータ列数(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 vntData As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
Set rngList = ActiveSheet.Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成(C列に)
With .Offset(1, clngColumns)
.Value = 1
.Resize(lngRows).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, Step:=1, Trend:=False
End With
'データをA列で整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngKey), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'A列データを配列に取得
vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
'復帰用整列Keyを配列に取得
vntData = .Offset(1, clngColumns).Resize(lngRows + 1).Value
End With
For i = 2 To lngRows
'一つ上の値と現在値が同じ場合
If vntKeys(i - 1, 1) = vntKeys(i, 1) Then
'復帰用整列KeyをEmptyに
vntData(i, 1) = Empty
'削除行数をカウント
lngCount = lngCount + 1
End If
Next i
With rngList
'復帰用整列Keyを出力
.Offset(1, clngColumns).Resize(lngRows).Value = vntData
'復帰用Keyを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
'削除行が有った場合
If lngCount > 0 Then
'不用行を削除
.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
|
|