Excelで指定のｷｰﾜｰﾄﾞを含む行を削除したいです｡こんな感じで､どうでしょうか｡
Const SPEED_UP = False ' True で速くなる Const MAX_ROW = 300000 ' 突っ走るのが怖いので Const KEYWORD = "りんご" Sub Delete_Row_Include_Keyword() On Error GoTo ErrorHandler If SPEED_UP Then 'ﾜｰｸｼｰﾄに描画しない Application.ScreenUpdating = False End If r = 1 Do While r < MAX_ROW Set c = Cells(r, 7) If IsEmpty(c) Or c.Value = "" Then Exit Do End If If InStr(c.Value, KEYWORD) > 0 Then c.EntireRow.Delete Else r = r + 1 End If Loop FINAL: If SPEED_UP Then '結果を描画する Application.ScreenUpdating = True End If Exit Sub ErrorHandler: GoTo FINAL End Sub
行を削除したいｼｰﾄを選択した状態で､このｻﾌﾞﾙｰﾁﾝを実行してください｡
先頭の方にある KEYWORD を､適当に変えてください｡
G列のｾﾙが､空の行が出てくると､そこで止まります｡
処理が延々と終了しないのは､ちょっと恐いので､行数のｶｳﾝﾄで最大の行数も指定してます｡
SPEED_UP という定数を True にすると､画面の描画を止めるので､少し早くなります｡
中程度のﾉｰﾄﾌﾞｯｸで､2500行くらいで 0.5秒くらいです｡
それでも､30万行もあると､ﾊﾟｿｺﾝの性能にもよりますが､数分かかると思います｡
ﾊﾞｯｸｱｯﾌﾟを取ってから､試してみてください｡
こんな感じでしょうか｡
Public Sub DeleteRow()
Dim KeyWord As String
Dim R As Long
Dim MaxRow As Long
KeyWord = "er" '削除の条件
'G列がｷｰなのでG列で最終行を取得する
MaxRow = Range("G" & Cells.Rows.Count).End(xlUp).Row
'最後の行から1行目まで後ろからﾙｰﾌﾟさせることで読み飛ばしを回避する
For R = MaxRow To 1 Step -1
If Range("G" & R) = KeyWord Then
Rows(R).Delete
End If
DoEvents
Next
End Sub
1行目から順に･･･とすると削除すると行がずれてしまうので､後ろから順にまわすのがｾｵﾘｰです｡
そうそう､速くするには Application.ScreenUpdating = Falseにしておきましょう｡ DoEventsで｢応答なし｣を回避しています｡毎回のﾙｰﾌﾟではおおすぎるのならDoEventsの行を次のようにしてもいいでしょう｡
If R Mod 100 = 0 Then
DoEvents
Application.StatusBar = R & " / " & MaxRow
End If
100行ごとにDoEventsとｽﾃｰﾀｽﾊﾞｰへ進行状況のﾒｯｾｰｼﾞを書き込みます｡
条件も｢含む｣であるなら Like とかInstrとかを使って書き直す必要があります｡
| ▽4
●
Mook ●300ﾎﾟｲﾝﾄ  ﾍﾞｽﾄｱﾝｻｰ |
まともに行削除をすると数分ｵｰﾀﾞｰなので､削除を一度にする例です｡
ｾﾙの結合等あるとできないので､そのときは0ﾎﾟｲﾝﾄ配分で結構です｡
作業列としてZ列を使用しているので､ﾃﾞｰﾀがZ列以降にもある場合は､
ｺｰﾄﾞ中のZを十分大きな列名に変更してください｡
30万行のﾃﾞｰﾀで約3秒でした｡
Option Explicit Sub Main() Dim st st = Timer() DeleteRow "りんご", "G" Debug.Print Timer() - st End Sub Sub DeleteRow(keyWord As String, searchCol As String) Const DelNum = 9999999 Const WorkCol = "Z" Dim lastRow As Long lastRow = Cells(Rows.Count, searchCol).End(xlUp).Row Dim kt kt = Cells(1, searchCol).Resize(lastRow) Dim st st = Cells(1, WorkCol).Resize(lastRow) Dim r As Long For r = 1 To lastRow If InStr(kt(r, 1), keyWord) = 0 Then st(r, 1) = r Else st(r, 1) = DelNum End If Next Cells(1, WorkCol).Resize(lastRow) = st ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add _ Key:=Cells(1, WorkCol).Resize(lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveSheet.Sort .SetRange Range("A1").Resize(lastRow, Cells(1, WorkCol).Column) .Header = xlGuess .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Dim f As Range Set f = Columns(WorkCol).Find(DelNum, lookat:=xlWhole) If Not f Is Nothing Then Rows(f.Row & ":" & lastRow).Delete Columns(WorkCol).ClearContents End Sub
