ExcelのVBAについて。


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

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


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

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

Next i

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/03/03 02:27:22
  • 終了:2013/03/07 23:33:08

ベストアンサー

id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912013/03/03 16:16:59

ポイント50pt

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


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

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
id:tetlis

「そのようなことができたらいいな」とは思っていたのですが、やり方がわかりませんでした。ありがとうございます。

2013/03/07 23:32:38

その他の回答(2件)

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492013/03/03 02:43:35

ポイント20pt

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

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
id:tetlis

ありがとうございます、これも取り入れてみ王と思います。

2013/03/07 23:31:39
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982013/03/03 06:26:31

ポイント33pt

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

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

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

id:tetlis

フィルタからはなぜか逃げていました。やってみようと思います。

2013/03/07 23:32:08
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912013/03/03 16:16:59ここでベストアンサー

ポイント50pt

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


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

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
id:tetlis

「そのようなことができたらいいな」とは思っていたのですが、やり方がわかりませんでした。ありがとうございます。

2013/03/07 23:32:38

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません