VBAを使用して2行目と3行目を削除する

Question

私は、中規模のデータセットの3分の2をすばやく削除するための洞察を求めています。現在、スペース区切りのデータをテキストファイルからExcelにインポートしていますが、行ごとにデータを削除するためにループを使用しています。ループはデータの最下行から開始し、上に行く行を削除します。データは時間順に並べられており、データの最初または最後の3分の2を単に切り捨てることはできません。本質的に何が起きているのかは、データが過度にサンプリングされており、あまりにも多くのデータポイントが互いに接近しすぎていることです。それは辛抱強く遅いプロセスであり、私は別の方法を探しています。

Sub Delete() 

Dim n As Long 

n = Application.WorksheetFunction.Count(Range("A:A")) 

Application.Calculation = xlCalculationManual 

Do While n > 5 

n = n - 1 
Rows(n).Delete 
n = n - 1 
Rows(n).Delete 
n = n - 1 

Loop 

    Application.Calculation = xlCalculationAutomatic 

End Sub 

Answer 1

一定数だけステッピング可能ループのための使用：

For i = 8 To n Step 3

使用ユニオン範囲変数に格納されたばらばらの範囲を作成します。

Set rng = Union(rng, .Range(.Cells(i + 1, 1), .Cells(i + 2, 1)))

そして、一度にすべてを削除します。

rng.EntireRow.Delete

促進するためのもう一つの良い習慣は、の使用は、常に任意の範囲オブジェクトの親を宣言です。あなたのコードがますます複雑になるにつれて、両親が問題につながると宣言することはありません。

Withブロックを使用します。

With Worksheets("Sheet1")

我々はその親へのリンクを示すために.で、すべての範囲のオブジェクトを先行することができます。あなたは配列を使用して新しい配列に行の3分の1を書き出すことができ

Set rng = .Range("A6:A7")

Sub Delete() 

Dim n As Long 
Dim i As Long 
Dim rng As Range 

Application.Calculation = xlCalculationManual 

With Worksheets("Sheet1") 'change to your sheet 
    n = Application.WorksheetFunction.Count(.Range("A:A")) 

    Set rng = .Range("A6:A7") 

    For i = 8 To n Step 3 
     Set rng = Union(rng, .Range(.Cells(i + 1, 1), .Cells(i + 2, 1))) 
    Next i 
End With 

rng.EntireRow.Delete 

Application.Calculation = xlCalculationAutomatic  


End Sub 

Answer 2

。オリジナルをクリアした後、画面にプリントアウトします。

もしあれば式を失うでしょう。あなたが基本的なデータセットを持っていれば、これはあなたに適しているかもしれません。それは私がループに関心のすべての行をマルチ選択し、すべての行を選択した後に1行のコードで、削除を行うに見て、

Sub MyDelete() 
    Dim r As Range 
    Set r = Sheet1.Range("A1").CurrentRegion 'perhaps define better 
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1) ' I assume row 1 is header row. 

Application.ScreenUpdating = False 

    Dim arr As Variant 
    arr = r.Value 

    Dim newArr() As Variant 
    ReDim newArr(1 To UBound(arr), 1 To UBound(arr, 2)) 
    Dim i As Long, j As Long, newCounter As Long 
    i = 1 
    newCounter = 1 

    Do 
     For j = 1 To UBound(arr, 2) 
      newArr(newCounter, j) = arr(i, j) 
     Next j 

     newCounter = newCounter + 1 
     i = i + 3 
    Loop While i <= UBound(arr) 

    r.ClearContents 
    Sheet1.Range("A2").Resize(newCounter - 1, UBound(arr, 2)).Value = newArr 

Application.ScreenUpdating = True 

End Sub