Excel VBA質問箱 IV

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

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


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

43423 / 76732

←次へ　｜　前へ→


	【38357】Re:検索～比較～行削除

Hirofumi - 06/5/31(水) 20:02 -


	引用なし

	パスワード

もう見て居ないかな？

こんなのも有るよ

Option Explicit

Public Sub Repetition()

　　'データの列数(基準位置からの列数、この列の1列外側を作業列にします)
　　'例えば、基準セル位置がA列で、データがAB列まで有るなら
　　Const clngColumns As Long = 28

　　'重複を比較する列（基準列位置からの列Offset)
　　'例えば、基準セル位置がA列で、比較列がAB列なら
　　Const clngKeys As Long = 27
　　
　　Dim i As Long
　　Dim lngRows As Long
　　Dim lngCount As Long
　　Dim rngList As Range
　　Dim vntData As Variant
　　Dim dicIndex As Object
　　Dim lngFlags() As Long
　　Dim strProm As String
　　　　
　　'データの左上隅を基準とする
　　Set rngList = ActiveSheet.Cells(1, "A")
　　With rngList
　　　　'データ行数を取得
　　　　lngRows = .Offset(Rows.Count - .Row, _
　　　　　　　　　　　　　　clngKeys).End(xlUp).Row - .Row + 1
　　　　If lngRows <= 1 And .Value = "" Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'Keyを配列に取得
　　　　vntData = .Offset(, clngKeys).Resize(lngRows + 1).Value
　　End With
　　'Flagを格納する配列を確保
　　ReDim lngFlags(1 To lngRows, 1 To 1)

　　Application.ScreenUpdating = False

　　'Dictionaryオブジェクトを取得
　　Set dicIndex = CreateObject("Scripting.Dictionary")

　　With dicIndex
　　　　'データ行数分繰り返し
　　　　For i = 1 To lngRows
　　　　　　'Keyの登録が有るなら（重複が有る)
　　　　　　If .Exists(vntData(i, 1)) Then
　　　　　　　　'削除フラグを立てる
　　　　　　　　lngFlags(i, 1) = 1
　　　　　　　　'削除数をカウント
　　　　　　　　lngCount = lngCount + 1
　　　　　　Else
　　　　　　　　'Keyの登録
　　　　　　　　.Add vntData(i, 1), Empty
　　　　　　End If
　　　　Next i
　　End With
　　
　　Set dicIndex = Nothing

　　With rngList
　　　　'削除する行が合った場合
　　　　If lngCount > 0 Then
　　　　　　'削除フラグの配列をデータ列の右側に出力
　　　　　　.Offset(, clngColumns).Resize(lngRows).Value = lngFlags
　　　　　　'削除フラグの列をKeyとして整列
　　　　　　.Resize(lngRows, clngColumns + 1).Sort _
　　　　　　　　Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
　　　　　　　　Header:=xlNo, OrderCustom:=1, _
　　　　　　　　MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlStroke
　　　　　　'行削除
　　　　　　.Offset(lngRows - lngCount) _
　　　　　　　　　　　　.Resize(lngCount).EntireRow.Delete
　　　　　　''削除フラグの列を消去
　　　　　　.Offset(, clngColumns).EntireColumn.ClearContents
　　　　　　strProm = lngCount & " 行の削除が完了しました"
　　　　Else
　　　　　　strProm = "重複行が有りません"
　　　　　　GoTo Wayout
　　　　End If
　　End With

Wayout:

　　Application.ScreenUpdating = True

　　Set rngList = Nothing

　　MsgBox strProm, vbInformation

End Sub

0 hits

▼

【38314】検索～比較～行削除 ゆっけ 06/5/31(水) 11:04