Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

59695 / 76732

←次へ　｜　前へ→


	【21713】Re:重複するデータの削除について

Hirofumi - 05/1/27(木) 21:21 -


	引用なし

	パスワード

こんなのでどお？

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

2 hits

▼

【21692】重複するデータの削除について もくたん 05/1/27(木) 0:37