| |
こんなのでどお？
Option Explicit
Public Sub Sample()
Dim i As Long
Dim rngResult As Range
Dim vntdata As Variant
Dim dicIndex As Object
Dim lngRows As Long
Application.ScreenUpdating = False
'Sheet2の出力位置を指定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'Listの有るシートのList左上隅を指定（住所のセル）
With Worksheets("Sheet1").Cells(1, "A")
'データ行数を取得
lngRows = .Offset(65536 - .Row, 1).End(xlUp).Row - .Row + 1
'データが無い時は終了
If lngRows <= 1 Then
GoTo Wayout
End If
'氏名の列を配列に取得
vntdata = .Offset(, 1).Resize(lngRows).Value
'Sheet2にSheet1のListをコピー
.CurrentRegion.Copy _
Destination:=rngResult.Offset(, 1)
End With
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'氏名列全てを繰り返す
For i = 2 To UBound(vntdata, 1)
'もし、Indexに登録が有るなら
If .Exists(vntdata(i, 1)) Then
'最初に登録した氏名をEmptyに
vntdata(.Item(vntdata(i, 1)), 1) = Empty
'重複した氏名をEmptyに
vntdata(i, 1) = Empty
Else
'Indexに氏名をKeyに並び順を登録
.Add vntdata(i, 1), i
'配列に並び順を代入
vntdata(i, 1) = i
End If
Next i
End With
'Dictionaryを破棄
Set dicIndex = Nothing
'配列の先頭に列見出しを代入
vntdata(1, 1) = "Number"
'配列のEmpty数を取得
lngRows = 0
For i = 2 To UBound(vntdata, 1)
If vntdata(i, 1) = Empty Then
lngRows = lngRows + 1
End If
Next i
With rngResult
'結果をSheet2のA列に出力
.Resize(UBound(vntdata, 1)).Value = vntdata
'A列をKeyとしてソート
.CurrentRegion.Sort Key1:=.Item(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
'A列がEmptyの行を削除
.End(xlDown).Offset(1).Resize(lngRows).EntireRow.Delete
'A列を削除
.EntireColumn.Delete
End With
Wayout:
Application.ScreenUpdating = True
Set rngResult = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
