人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

ExcelのVBAについて。

A列に記入した日付が期間外の場合は、その行を削除するコードを書いています。
処理が早い方法はないでしょうか。

以下の様なコードでやっているのですが、数千行になると遅いです。


For i = 最後の行 To 最初の行 Step -1

If i行の日付 < 期間開始日 Or
i行の日付 > 期間終了日 Then
Range(i & ":" & i).Delete
End If

Next i

●質問者: tetlis
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● うぃんど
●20ポイント

画面更新と再計算を一時的に止めると良いでしょう。

Application.ScreenUpdating = False
ActiveSheet.EnableCalculation = False

For i = 最後の行 To 最初の行 Step -1

If i行の日付 < 期間開始日 Or
i行の日付 > 期間終了日 Then
Range(i & ":" & i).Delete
End If

Next i

ActiveSheet.EnableCalculation = True
Application.ScreenUpdating = True

tetlisさんのコメント
ありがとうございます、これも取り入れてみ王と思います。

2 ● きゃづみぃ
●33ポイント

フィルタが使えれば 速いですよ。

Sub test()
 Dim 期間開始日 As String
 Dim 期間終了日 As String
 期間開始日 = "2013/3/6"
 期間終了日 = "2013/3/8"
 最初の行 = 1
 最後の行 = 100
 
 sh = ActiveSheet.Name
 Rows(最初の行).Insert Shift:=xlDown
 最後の行 = 最後の行 + 1
 
 Rows(最初の行 & ":" & 最後の行).Select
 Selection.AutoFilter
 Selection.AutoFilter Field:=1, Criteria1:=">=" & 期間開始日, Criteria2:="<=" & 期間終了日
 最初の行2 = 最初の行 + 1
 Rows(最初の行2 & ":" & 最後の行).Select
 Selection.Copy
 Sheets.Add
 ActiveSheet.Rows(最初の行).Select
 ActiveSheet.Paste
 ActiveSheet.Range("A" & 最初の行).Select
 Application.CutCopyMode = False
 
 Worksheets(sh).Select
 Selection.AutoFilter
 Rows(最初の行).Delete
 Cells(最初の行, "A").Select
End Sub


期間開始日 = "2013/3/6"
期間終了日 = "2013/3/8"
最初の行 = 1
最後の行 = 100

ここは 適宜変更してください。
新しくシートを作って そちらに 必要な範囲のみコピーします。


tetlisさんのコメント
フィルタからはなぜか逃げていました。やってみようと思います。

3 ● Mook
●50ポイント ベストアンサー

一番コストの遅い処理は行を削除する処理ですから、
いっぺんに消すようにしたらどうでしょうか。


期間や範囲の日付は適宜変更してください。

Option Explicit

Sub DeleteDate()
 Dim delArea As Range
 Set delArea = Nothing
 
 Dim 期間開始日 As Date
 期間開始日 = CDate("2013/1/1")
 
 Dim 期間終了日 As Date
 期間終了日 = CDate("2013/3/10")
 
 Dim r As Range
 For Each r In Range("D2:D2000")  '// 日付の範囲
 If DateDiff("d", r.Value, 期間開始日) > 0 Or DateDiff("d", r.Value, 期間終了日) < 0 Then
 If delArea Is Nothing Then
 Set delArea = r
 Else
 Set delArea = Union(delArea, r)
 End If
 End If
 Next
 If Not delArea Is Nothing Then
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 
 delArea.EntireRow.Delete
 
 Application.EnableEvents = True
 Application.ScreenUpdating = True
 End If
End Sub

tetlisさんのコメント
「そのようなことができたらいいな」とは思っていたのですが、やり方がわかりませんでした。ありがとうございます。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ