Excel VBA質問箱 IV

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

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


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

32576 / 76734

←次へ　｜　前へ→


	【49393】Re:特定の行のみ削除する方法がわかりません。

Hirofumi - 07/6/3(日) 19:54 -


	引用なし

	パスワード

こんな事？

Option Explicit

Public Sub Repetition()

　　'データの列数
　　Const clngColumns As Long = 5
　　'重複を取る列位置（基準セル位置からの列Offset）
　　Const clngKey As Long = 0
　　
　　Dim i As Long
　　Dim lngRows As Long
　　Dim lngTop As Long
　　Dim lngCount As Long
　　Dim rngList As Range
　　Dim vntData As Variant
　　Dim lngNumb() As Long
　　Dim strProm As String
　　
　　'画面更新の停止
　　Application.ScreenUpdating = False
　　
　　'データの左上隅を基準とする
　　Set rngList = ActiveSheet.Cells(1, "A")
　　With rngList
　　　　'データ行数を取得
　　　　lngRows = .Offset(65536 - .Row, clngKey).End(xlUp).Row - .Row + 1
　　　　If lngRows <= 1 And .Value = "" Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'復帰用Keyを作成
　　　　ReDim lngNumb(1 To lngRows, 1 To 1)
　　　　For i = 1 To lngRows
　　　　　　lngNumb(i, 1) = i
　　　　Next i
　　　　'復帰用Keyを出力
　　　　.Offset(, clngColumns).Resize(lngRows).Value = lngNumb()
　　　　'データKeyで整列
　　　　.Resize(lngRows, clngColumns + 1).Sort _
　　　　　　　　Key1:=.Offset(, clngKey), Order1:=xlAscending, _
　　　　　　　　Header:=xlNo, OrderCustom:=1, _
　　　　　　　　MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlStroke
　　　　'Keyを配列に取得
　　　　vntData = .Offset(, clngKey).Resize(lngRows + 1).Value
　　End With

　　'比較元位置を先頭に
　　lngTop = 1
　　'データ行数分繰り返し
　　For i = 2 To lngRows
　　　　'Keyの重複が有るなら
　　　　If vntData(lngTop, 1) = vntData(i, 1) Then
　　　　　　'削除フラグを立てる
　　　　　　lngNumb(i, 1) = 1
　　　　　　'削除数をカウント
　　　　　　lngCount = lngCount + 1
　　　　Else
　　　　　　'比較元位置を更新
　　　　　　lngTop = i
　　　　　　lngNumb(i, 1) = 0
　　　　End If
　　Next i
　　
　　With rngList
　　　　'削除する行が合った場合
　　　　If lngCount > 0 Then
　　　　　　'削除フラグの配列を復帰用Key列の右側に出力
　　　　　　.Offset(, clngColumns + 1).Resize(lngRows).Value = lngNumb
　　　　　　'削除フラグの列をKeyとして整列
　　　　　　.Resize(lngRows, clngColumns + 2).Sort _
　　　　　　　　　　Key1:=.Offset(, clngColumns + 1), Order1:=xlAscending, _
　　　　　　　　　　Key2:=.Offset(, clngColumns), Order2:=xlAscending, _
　　　　　　　　　　Header:=xlNo, OrderCustom:=1, _
　　　　　　　　　　MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　　　　　　　SortMethod:=xlStroke
　　　　　　'行削除
　　　　　　.Offset(lngRows - lngCount) _
　　　　　　　　　　　　.Resize(lngCount).EntireRow.Delete
　　　　　　''削除フラグの列を削除
　　　　　　.Offset(, clngColumns).Resize(, 2).EntireColumn.Delete
　　　　Else
　　　　　　strProm = "重複行が有りません"
　　　　　　GoTo Wayout
　　　　End If
　　End With

　　strProm = "処理が完了しました"

Wayout:

　　'画面更新の再開
　　Application.ScreenUpdating = True

　　Set rngList = Nothing

　　MsgBox strProm, vbInformation

End Sub

4 hits

▼

【49390】特定の行のみ削除する方法がわかりません。 とっきぃ 07/6/3(日) 19:25