| |
'では、こんなのでは？
'先頭行は列見出しとします
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
|
|
Hirofumi
- 10/10/22(金) 18:43 -
