Excelで複数のワークシートを使ってセルを削除する高速コード

Question

私はVBの初心者で、グーグルで答えを探しました。複数のExcelワークシートを循環させ、セルに特定の要素が含まれている行を削除するには、 N/A＃N/A＃）。

クリーニングするxlシートのデータは、DATE、OPENの財務データです。ハイクローズ。行数が重要になり、ワークシートの数は2〜3,000になります。それは動作しますが、非常に遅く、私が学んでいるように、このコードをより速くする方法についての助けを感謝します。ありがとうございました。

Sub DataDeleteStage1() 

    ScreenUpdating = False 

     Dim lrow As Long 
     Dim ws As Worksheet 
     Dim icntr As Long 


     For Each ws In ThisWorkbook.Worksheets 

       lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row 
       For icntr = lrow To 1 Step -1 

       If ws.Name <> "HEADER" Then 
       If ws.Cells(icntr, "B") = "#N/A N/A" And ws.Cells(icntr, "C") = "#N/A N/A" And ws.Cells(icntr, "D") = "#N/A N/A" And ws.Cells(icntr, "E") = "#N/A N/A" Then 
          ws.Rows(icntr).EntireRow.Delete 
       End If 
       End If 

       Next icntr 

     Next ws 

    End Sub 

Answer 1

RangeをすべてMergeRngオブジェクトに削除してから一度に削除してみてください。

コード

Sub DataDeleteStage1() 

ScreenUpdating = False 

Dim lrow As Long 
Dim ws As Worksheet 
Dim icntr As Long 
Dim MergeRng As Range 

For Each ws In ThisWorkbook.Worksheets 
    With ws 
     lrow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     For icntr = lrow To 1 Step -1 
      If .Name <> "HEADER" Then 
       If .Cells(icntr, "B") = "#N/A N/A" And .Cells(icntr, "C") = "#N/A N/A" And .Cells(icntr, "D") = "#N/A N/A" And .Cells(icntr, "E") = "#N/A N/A" Then 
        If Not MergeRng Is Nothing Then 
         Set MergeRng = Application.Union(MergeRng, .Rows(icntr)) 
        Else 
         Set MergeRng = .Rows(icntr) 
        End If 
       End If 
      End If 
     Next icntr 

     ' Delete all rows at once 
     If Not MergeRng Is Nothing Then MergeRng.Delete 
    End With 

    Set MergeRng = Nothing ' reset range when changing worksheets 

Next ws 

End Sub 

Answer 2

コードを削除するのは1回で、毎回ではありません。 このようにそれを行うために、次のことを試してください。

Sub DataDeleteStage1() 

    Application.ScreenUpdating = False 

    Dim lrow  As Long 
    Dim ws   As Worksheet 
    Dim icntr  As Long 

    Dim delRange As Range 

    For Each ws In ThisWorkbook.Worksheets 

     lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row 
     For icntr = lrow To 1 Step -1 
      If ws.Name <> "HEADER" Then 
       If ws.Cells(icntr, "B") = "#N/A N/A" And _ 
        ws.Cells(icntr, "C") = "#N/A N/A" And _ 
        ws.Cells(icntr, "D") = "#N/A N/A" And _ 
        ws.Cells(icntr, "E") = "#N/A N/A" Then 

        If Not delRange Is Nothing Then 
         Set delRange = ws.Rows(icntr) 
        Else 
         Set delRange = Union(delRange, ws.Rows(icntr)) 
        End If 
       End If 
      End If 
     Next icntr 

     If Not delRange Is Nothing Then delRange.Delete 
     Set delRange = Nothing 

    Next ws 
End Sub 

私はそれを試していないが、それは動作するはずです。

Answer 3

私がテストしたが、これについて

Sub DataDeleteStage1() 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    Dim lrow As Long 
    Dim ws As Worksheet 
    Dim icntr As Long 

    For Each ws In ThisWorkbook.Worksheets 

     lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row 

     If ws.Name <> "HEADER" Then 
     On Error Resume Next 
      Range("F1:F" & lrow).Formula = "=IF(SUMPRODUCT(--ISERROR(A1:E1))=5,NA(),"""")" 
      Range("F1:F" & lrow).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete shift:=xlUp 
      Range("F1:F" & lrow).Clear 

     End If 

    Next ws 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 

End Sub 

Answer 4

どのようにこれを試してみませんか？オートフィルタでかつ完全にループのない

Sub DeleteRows() 
Dim ws As Worksheet 
With Application 
    .Calculation = xlCalculationManual 
    .EnableEvents = False 
    .ScreenUpdating = False 
End With 

For Each ws In ThisWorkbook.Sheets 
    If ws.Name <> "HEADER" Then 
     On Error Resume Next 
     ws.Columns("B:E").Replace "#N/A N/A", "=NA()" 
     ws.Columns("B:E").SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete 
    End If 
Next ws 
With Application 
    .Calculation = xlCalculationAutomatic 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 
End Sub 

Answer 5

：

Sub DataDeleteStage1() 
Dim ws As Worksheet 
Dim lr As Integer 
Application.ScreenUpdating = False 

For Each ws In ThisWorkbook.Worksheets 
    With ws 
     lr = .Range("A" & .Rows.Count).End(xlUp).Row 
     If ws.Name <> "HEADER" Then 
      .UsedRange.AutoFilter Field:=2, Criteria1:="#N/A" 
      .UsedRange.AutoFilter Field:=3, Criteria1:="#N/A" 
      .UsedRange.AutoFilter Field:=4, Criteria1:="#N/A" 
      .UsedRange.AutoFilter Field:=5, Criteria1:="#N/A" 
      .Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlUp 
     End If 
    End With 
Next ws 
Application.ScreenUpdating = True 
End Sub 

は300Kの行にマージされた範囲のアプローチ対これをテスト - 複数のシートをするとき分速いです。