Если в столбце K есть 0, удалите строки C в K и сдвиньте ячейки вверх

Question

У меня есть код, который просматривает столбец K, проверяет, есть ли 0 и, если есть, удаляет соответствующие строки от C до K.

Sub del()


Application.ScreenUpdating = False 'Prevent screen flickering
Application.Calculation = xlCalculationManual 'Preventing calculation

Dim sh As Worksheet, lr As Long, i As Long, lngStartRow As Long

Set sh = Sheets("Formations_Tracker")
lr = sh.Cells(Rows.Count, "C").End(xlUp).Row
lngStartRow = 2 'Starting data row number.

For i = lr To lngStartRow Step -1
    If sh.Cells(i, "K") = 0 Then
        sh.Cells(i, "K").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "J").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "I").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "H").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "G").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "F").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "E").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "D").Resize(1, 2).Delete Shift:=xlUp
        sh.Cells(i, "C").Resize(1, 2).Delete Shift:=xlUp
    End If
Next i

Set sh = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Проблема в том, что это работает если последняя строка содержит ту, которая содержит 0. Однако если это не последняя строка, кажется, что удаляются дополнительные строки, даже те, в которых нет нулей.

Answer 1

Вы можете уменьшить это l oop до простого фильтра и удалить. Обратите внимание, что это удаляет всю строку, так что это может потребовать некоторых изменений на вашем конце, чтобы удовлетворить ваши потребности

Sub del()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Formations_Tracker")
Dim LR As Long
Dim DeleteMe As Range

LR = ws.Range("K" & ws.Rows.Count).End(xlUp).Row

Application.DisplayAlerts = False

    ws.Range("C1:K" & LR).AutoFilter Field:=9, Criteria1:=0
    Set DeleteMe = ws.Range("C2:K" & LR).SpecialCells(xlCellTypeVisible)
    ws.AutoFilterMode = False
    If Not DeleteMe Is Nothing Then DeleteMe.Delete (xlShiftUp)

Application.DisplayAlerts = True

End Sub

Answer 2

Вот еще один подход:

Option Explicit
Sub del()

    Application.ScreenUpdating = False 'Prevent screen flickering
    Application.Calculation = xlCalculationManual 'Preventing calculation

    'you should also reference the workbook
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Formations_Tracker")
    'ThisWorkbook refers to the workbook which contains the code

    Dim lngStartRow As Long
    lngStartRow = 2 'Starting data row number.

    Dim lr As Long
    lr = sh.Cells(Rows.Count, "C").End(xlUp).Row

    'When looping through cells is always better to use the For Each
    Dim C As Range

    'It would be wise to delete everything at once using a range to delete
    Dim DelRange As Range

    For Each C In sh.Range("K" & lngStartRow & ":K" & lr)
        If C = 0 Then
            If DelRange Is Nothing Then
                Set DelRange = C
            Else
                Set DelRange = Union(DelRange, C)
            End If
        End If
    Next C

    'Delete all your rows at once if there is a match
    If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
    Set sh = Nothing
    Set DelRange = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub