Excel VBA質問箱 IV

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

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


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

15235 / 76734

←次へ　｜　前へ→


	【66980】Re:AutoFilter以外の方法

Hirofumi - 10/10/22(金) 18:43 -


	引用なし

	パスワード

'では、こんなのでは？
'先頭行は列見出しとします

Option Explicit

Public Sub Sample_2()

　　'Listのデータ列数（B列）
　　Const clngColumns As Long = 1
　　'Keyと成る列位置(基準セルからの列Offsetで指定：B列 = 0)
　　Const clngKey As Long = 0
　　'Keyと成る文字列
　　Const cstrKey As String = "orange"
　　
　　Dim i As Long
　　Dim lngRows As Long
　　Dim lngCount As Long
　　Dim rngList As Range
　　Dim lngNumb() As Long
　　Dim vntKeys() As Variant
　　Dim strProm As String
　　
　　Dim sngTime1 As Single
　　Dim sngTime2 As Single
　　
　　sngTime2 = Timer

　　'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
　　Set rngList = ActiveSheet.Range("B1")

　　'Listに対しての前処理
　　With rngList
　　　　'行数の取得
　　　　lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
　　　　If lngRows <= 0 Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'L列の値を配列として取得
　　　　vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
　　End With
　　
　　'削除用整列Keyを格納する配列を確保
　　ReDim lngNumb(1 To lngRows, 1 To 1)
　　
　　'List最終行まで繰り返し
　　For i = 1 To lngRows
　　　　'L列の値が"Kg"でないなら
　　　　If StrComp(vntKeys(i, 1), cstrKey, vbTextCompare) <> 0 Then
　　　　　　'R列の値をEmptyに（削除行）
　　　　　　lngNumb(i, 1) = 1
　　　　　　'削除行をカウントする
　　　　　　lngCount = lngCount + 1
　　　　End If
　　Next i
　　
　　'画面更新を停止
　　Application.ScreenUpdating = False
　　
　　With rngList
　　　　'削除行が有るなら
　　　　If lngCount > 0 Then
　　　　　　If MsgBox(lngCount & "件が該当します、削除しますか？", _
　　　　　　　　　　vbYesNo + vbInformation) = vbYes Then
　　　　　　　　'List最終列の後ろ列(R列)に削除Flagを出力
　　　　　　　　.Offset(1, clngColumns).Resize(lngRows).Value = lngNumb
　　　　　　　　'Listを削除Flag昇順、復帰Key昇順で整列
　　　　　　　　DataSort .Offset(1).Resize(lngRows, clngColumns + 1), .Offset(1, clngColumns)
　　　　　　　　'不要データを削除
　　　　　　　　.Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
　　　　　　　　'復帰用Keyと削除Flagを消去
　　　　　　　　.Offset(, clngColumns).EntireColumn.ClearContents
　　　　　　　　strProm = lngCount & "件を削除しました"
　　　　　　Else
　　　　　　　　strProm = "削除を中止しました"
　　　　　　End If
　　　　Else
　　　　　　strProm = "該当行は在りません"
　　　　End If
　　End With
　　　
Wayout:

　　'画面更新を再開
　　Application.ScreenUpdating = True
　　
　　Set rngList = Nothing
　　　
　　sngTime1 = Timer
　　
　　MsgBox strProm & vbLf & (sngTime1 - sngTime2), vbInformation
　　
End Sub

Private Sub DataSort(rngScope As Range, _
　　　　　　　　　　rngKey As Range, _
　　　　　　　　　　Optional lngSortOrder As Long = xlAscending, _
　　　　　　　　　　Optional lngOrientation As Long = xlTopToBottom)

　　rngScope.Sort _
　　　　　　Key1:=rngKey, Order1:=lngSortOrder, _
　　　　　　Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
　　　　　　Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

6 hits

▼

【66975】AutoFilter以外の方法 にしもり 10/10/22(金) 16:03