1

次のVBAコードは、実行に非常に長い時間がかかります。25分前に48,000行実行しましたが、まだ実行中です。どうすれば実行時間を短縮できますか？

Sub delrows()

Dim r, RowCount As Long
r = 2

ActiveSheet.Columns(1).Select
RowCount = UsedRange.Rows.Count
userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info")

Rows(RowCount).Delete Shift:=xlUp

' Trim spaces

Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _
    ReplaceFormat:=False

' Delete surplus columns

Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select
    Selection.Delete Shift:=xlToLeft

' Delete surplus rows

Do
    If Left(Cells(r, 1), 1) = "D" _
       Or Left(Cells(r, 1), 1) = "H" _
       Or Left(Cells(r, 1), 1) = "I" _
       Or Left(Cells(r, 1), 2) = "MD" _
       Or Left(Cells(r, 1), 2) = "ND" _
       Or Left(Cells(r, 1), 3) = "MSF" _
       Or Left(Cells(r, 1), 5) = "MSGZZ" _
       Or Len(Cells(r, 1)) = 5 _
       Or Cells(r, 3) = 0 Then
       Rows(r).Delete Shift:=xlUp
    ElseIf Int(Right(Cells(r, 1), 4)) > 4000 Then
       Rows(r).Delete Shift:=xlUp
    Else: r = r + 1
    End If
Loop Until (r = RowCount)

End Sub
4

3 に答える 3

5

最大の問題は、おそらくループしているデータの量です。コードを更新して、行を削除する必要があるかどうかを確認する数式を作成しました。次に、その数式の結果をフィルタリングして、すべての行を一度に削除できます。

私はあなたがあなたのコードをきれいにしそして私がしたことを理解するのを助けるためにたくさんのコメントをしました。コメントの前に。を付け'=>ました。

最後に、値を配列にロードすることも役立つ場合がありますが、データの列が非常に多い場合、これはより困難になる可能性があります。私はそれについて多くの経験を持っていませんが、それが物事の世界をより速くすることを知っています！

頑張って楽しんでね！

Option Explicit

Sub delrows()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim r As Long, RowCount As Long
r = 2

Dim wks As Worksheet
Set wks = Sheets(1) '=> change to whatever sheet index (or name) you want

'=> rarely a need to select anything in VBA [ActiveSheet.Columns(1).Select]

With wks

    RowCount = .Range("A" & .Rows.Count).End(xlUp).Row '=> as opposed to  [RowCount = UsedRange.Rows.Count], as UsedRange can be misleading
                                                            'NOTE: this also assumes Col A will have your last data row, can move to another column

    userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info")

    .Rows(RowCount).Delete Shift:=xlUp

    ' Trim spaces

    '=> rarely a need to select anything in VBA [Columns("A:A").Select]
    .Range("A1:A" & RowCount).Replace What:=" ", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _
        ReplaceFormat:=False

    ' Delete surplus columns

    '=> rarely a need to select anything in VBA [Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select]
    .Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Delete Shift:=xlToLeft ' as opposed to Selection.Delete Shift:=xlToLeft

    ' Delete surplus rows

    '=> Now, here is where we help you loop:

    '=> First insert column to the right to capture your data
    .Columns(1).Insert Shift:=xlToRight
    .Range("A1:A" & RowCount).FormulaR1C1 = "=If(OR(Left(RC[1],1) = ""D"",Left(RC[1],1) = ""H"", Left(RC[1],1) = ""I"", Left(RC[1],2) = ""MD"",Left(RC[1],2) = ""ND"",Left(RC[1],3) = ""MSF"",Left(RC[1],5) = ""MSGZZ"",Len(RC[1])=5),""DELETE"",If(Int(Right(RC[1],4)) > 4000,""DELETE"",""""),""""))"

    '=> Now, assuming you something to delete ...
    If Not .Columns(1).Find("DELETE", LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then

        '=> filter and delete
        .Range("A1:A" & RowCount).AutoFilter 1, "DELETE"
        Intersect(.UsedRange, .UsedRange.Offset(1), .Range("A1:A" & RowCount)).SpecialCells(xlCellTypeVisible).EntireRow.Delete

    End If

    '=> Get rid of formula column
    .Columns(1).EntireColumn.Delete

End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With


End Sub
于 2012-12-07T17:10:43.003 に答える
4

非常に遅い理由は、各セルを反復処理しているためです。以下は配列にコピーし、削除が必要な行を見つけてから削除します。Sheet4をシートに更新し、Range（ "A2"）。CurrentRegionを必要な領域に更新します。

Dim data() As Variant
Dim count As Double, i As Double, z As Double, arrayCount As Double
Dim deleteRowsFinal As Range
Dim deleteRows() As Double

Application.ScreenUpdating = False

data = Sheet4.Range("A2").CurrentRegion.Value2

    For i = 1 To UBound(data, 1)        
        count = count + 1
        If (data(i, 1) = "D" Or Left(data(i, 1), 1) = "H" Or Left(data(i, 1), 1) = "I" Or Left(data(i, 1), 2) = "MD" _
                Or Left(data(i, 1), 2) = "ND" Or Left(data(i, 1), 3) = "MSF" Or Left(data(i, 1), 5) = "MSGZZ" _
                Or Len(data(i, 1)) = 5 Or data(i, 3) = 0 Or Int(Right(IIf(Cells(i, 1) = vbNullString, 0, Cells(i, 1)), 4)) > 4000) Then

            ReDim Preserve deleteRows(arrayCount)
            deleteRows(UBound(deleteRows)) = count
            arrayCount = arrayCount + 1                
        End If    
    Next i

    Set deleteRowsFinal = Sheet4.Rows(deleteRows(0))

    For z = 1 To UBound(deleteRows)
        Set deleteRowsFinal = Union(deleteRowsFinal, Sheet4.Rows(deleteRows(z)))
    Next z

    deleteRowsFinal.Delete Shift:=xlUp    

Application.ScreenUpdating = True
于 2012-12-07T17:43:32.217 に答える
2

まず、画面の更新をオフにします。以下にあなたの観察を追加してください。
計算に影響がないと思われる場合は、計算を無効にすることもできます。

Application.ScreenUpdating = False

your code...

Application.ScreenUpdating = True

編集：ここにファイルをアップロードしました-https: //dl.dropbox.com/u/24702181/TestDeleteRowsInChunk.xls

ブックはマクロ対応です。
開いた後、「データの回復」をクリックし、続いて「削除の開始」をクリックします。

詳細については、コードをご覧ください。さらに最適化できると思います。
いくつかのヒント

  • 逆ループを実行します。
  • 配列内のセルの内容を取得し、配列を使用して値を確認します。
  • 削除する行の文字列を作成します。
  • チャンクで削除します。
于 2012-12-07T15:06:50.677 に答える