EXCEL VBA – 行削除をまとめて短時間で行う方法

EXCEL
この記事は約2分で読めます。
スポンサーリンク

私は、EXCELでは、ワークシートのデータを別シートにデータベースとして保存していくマクロをよく使います。
その時、ある項目(例えば日付)について重複するデータがあればメッセージボックスで上書き可否を問いかけ、可なら上書きするのですが、その場合、まず、重複する行を削除する必要があります。
行数が多い場合、1行ずつ判定して行削除(EntireRow.Delete)していくのは時間がかかりますので、まずは削除対象をすべてRangeオブジェクトに格納して、EntireRow.Deleteを一度で済ませると格段に早くなります。

以下は、A列に日付が入っているワークシート(Sheet1)の2行目から最終行までをループし、A列セルが開始日(2017/3/16)から終了日(2018/3/15)の期間内の日付である行を削除するコードです。

 Option Explicit  '###### 期間内行削除 ###### Sub delete_Row()  Dim lRow As Long '最終行を見つけるための変数  Dim delArea As Range '削除対象のRangeオブジェクトを格納する変数  Set delArea = Nothing 'オブジェクトへの参照を解除       Dim ws As Worksheet  Set ws = Worksheets("Sheet1") '対象ワークシート       Dim startDate As Date '期間開始日  startDate = DateSerial(2017, 3, 16)  Dim endDate As Date '期間終了日  endDate = DateSerial(2018, 3, 15)       lRow = ws.Cells(Rows.Count, 1).End(xlUp).row 'A列最終行       Dim Rng As Range '削除対象を見つけるための変数  For Each Rng In Range(Cells(2, 1), Cells(lRow, 1)) '削除対象検索の範囲(A列日付)   '期間開始日とセル値の差が0日以上(セル値が期間開始日以上)かつ、   '期間終了日とセル値の差が0日以下(セル値が期間終了日以下)の場合   If DateDiff("d", startDate, Rng.Value)>= 0 And DateDiff("d", endDate, Rng.Value) <= 0 Then
   If delArea Is Nothing Then
    Set delArea = Rng '削除対象セルを格納
   Else
    Set delArea = Union(delArea, Rng) '次の削除対象セルを併せて格納を繰り返す
   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

上記はFor Each文を使っていますが、For Next文だと下記のようになります。

 Option Explicit  '###### 期間内行削除その2 ###### Sub delete_Row2()  Dim lRow As Long '最終行を見つけるための変数  Dim delArea As Range '削除対象のRangeオブジェクトを格納する変数  Set delArea = Nothing 'オブジェクトへの参照を解除   Dim ws As Worksheet  Set ws = Worksheets("Sheet1")'対象ワークシート   Dim startDate As Date '期間開始日  startDate = DateSerial(2017, 3, 16)  Dim endDate As Date '期間終了日  endDate = DateSerial(2018, 3, 15)   Dim r As Long '削除対象行を見つけるための変数  lRow = ws.Cells(Rows.Count, 1).End(xlUp).row 'A列最終行  For r = lRow To 2 Step -1 '最終行から2行目までループ   'セル値が期間開始日以上、かつ、期間終了日以下の場合   If ws.Cells(r, 1).Value>= startDate And ws.Cells(r, 1).Value <= endDate Then
   If delArea Is Nothing Then
    Set delArea = ws.Cells(r, 1) '削除対象セルを格納
   Else
    Set delArea = Union(delArea, ws.Cells(r, 1)) '次の削除対象セルを併せて格納を繰り返す
   End If
  End If
 Next r

 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

以上、ご参考になれば幸いです。

EXCEL
スポンサーリンク
スポンサーリンク
J.をフォローする
スポンサーリンク
アトリエJ.

コメント

タイトルとURLをコピーしました