| |
必ずデータのバックアップを取ってから実行して下さい
データListの有るシートをアクティブシートとします
データListの1行目は、列見出しが有る物とします
Option Explicit
Public Sub Redundancy()
Dim i As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim lngPos As Long
Dim vntData As Variant
Dim vntKeys As Variant
Dim dicIndex As Object
Dim rngList As Range
Dim strProm As String
'データListの左上隅（「ID」の列見出し位置）のセル位置を基準とする
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'List行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'List列数を取得
lngColumns = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column + 1
If lngRows < 2 Then
strProm = "データが有りません"
GoTo Wayout
End If
'「ID」列を配列に取得
vntData = .Resize(lngRows).Value
'「来店日」列を配列に取得
vntKeys = .Offset(, 2).Resize(lngRows).Value
End With
'Dictionaryオブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'データListの２行目（１行目は列見出しなので）から全てに繰り返し
For i = 2 To UBound(vntData, 1)
'DictionaryにIDの登録が有る場合
If .Exists(vntData(i, 1)) Then
'登録されたIDの行位置を取得
lngPos = .Item(vntData(i, 1))
'登録された位置の日付より現在の日付が後の場合
If vntKeys(lngPos, 1) < vntKeys(i, 1) Then
'現在のIDの位置に登録更新
.Item(vntData(i, 1)) = i
End If
Else
'IDと行位置を登録
.Add vntData(i, 1), i
End If
'ID配列の現在位置をクリア
vntData(i, 1) = Empty
Next i
'登録数を取得
lngPos = .Count
'登録されたKeyを全て取得
vntKeys = .Keys
'登録されたKeyを全てに繰り返し
For i = 0 To lngPos - 1
'残す行位置に"*"を書き込み
vntData(.Item(vntKeys(i)), 1) = "*"
Next i
End With
'Dictionaryオブジェクトのインスタンスを破棄
Set dicIndex = Nothing
Application.ScreenUpdating = False
'出力
With rngList
'残す行の印を最終列の後ろに出力
.Offset(, lngColumns).Resize(lngRows).Value = vntData
'残す行の印をKeyにて整列
With .Resize(lngRows, lngColumns + 1)
.Sort Key1:=.Item(1, lngColumns + 1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
End With
'削除する先頭行位置取得（行Offset）
lngPos = lngPos + 1
'削除する最終行位置取得（行Offset）
lngRows = lngRows - 1
'削除する行が有るなら
If lngPos <= lngRows Then
'行を削除
.Offset(lngPos).Resize(lngRows - lngPos + 1).EntireRow.Delete
End If
''残す行の印の有る列を削除
.Offset(, lngColumns).EntireColumn.Delete
End With
Application.ScreenUpdating = True
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
Beep
MsgBox strProm
End Sub
|
|
Hirofumi
- 05/3/20(日) 10:53 -
