| |
H17が先頭にある場合と言う条件なら
Option Explicit
Public Sub Test()
Dim Rw As Long
Application.ScreenUpdating = False
For Rw = Range("H65536").End(xlUp).Row To 1 Step -1
With Range("H" & Rw)
' If InStr(.Value, "H17*") > 0 Then .EntireRow.Delete
'先頭にH17が有る場合に削除
If InStr(1, .Value, "H17", vbBinaryCompare) = 1 Then
.EntireRow.Delete
End If
'文字列中の何処かにH17が有る場合に削除
' If InStr(1, .Value, "H17", vbBinaryCompare) > 0 Then
' .EntireRow.Delete
' End If
End With
Next Rw
Application.ScreenUpdating = True
End Sub
ただ、削除の速度を上げる為、以下の様な事もします
Public Sub Sample()
'データ列数(例えば基準位置A列〜I列までデータが有る場合)
Const clngColumns As Long = 9
'処理対象列位置(例えばH列、A列からの列Offset)
Const clngCompare As Long = 7
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim lngDelete() As Long
Dim lngCount As Long
Dim strProm As String
'Listの左上隅セル位置を基準として設定
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row, _
clngCompare).End(xlUp).Row - .Row + 1
'データが無い場合
If lngRows <= 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(, clngCompare).Resize(lngRows + 1).Value
'削除Flag用の配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
End With
'H17の時に削除Flagを入れる
For i = 1 To lngRows
'先頭にH17が有る場合に削除
If InStr(1, vntData(i, 1), "H17", vbBinaryCompare) = 1 Then
lngDelete(i, 1) = 1
lngCount = lngCount + 1
End If
Next i
'画面更新を停止
' Application.ScreenUpdating = False
With rngList
'削除Flagを出力
.Offset(, clngColumns).Resize(lngRows).Value = lngDelete
'削除FlagをKeyに整列
.Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
If lngCount > 0 Then
'Flag行の削除
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
End If
'削除Flagを削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 06/4/25(火) 21:19 -
