Удаление ячеек, если они содержат 0

Question

Я хочу удалить определенные ячейки во всех столбцах на моем листе, если они содержат 0, а затем сдвинуть все данные вверх.

Я нашел эту формулу в другом потоке, и по какой-то причине она работала только для одного столбца (столбец p) и работала только на половину этого.

Надеюсь, вам помогут эксперты.

Option Explicit 

Sub Sample() 
    Dim row_index As Long, lRow As Long, i As Long 
    Dim ws As Worksheet 
    Dim delRange As Range 

    '~~> Change this to the relevant worksheet 
    Set ws = ThisWorkbook.Sheets("Sheet1") 

    row_index = 7 

    Application.ScreenUpdating = False 

    With ws 
     lRow = .Range("P" & .Rows.Count).End(xlUp).Row 

     For i = row_index To lRow 
      If .Range("P" & i).Value <> "" And .Range("P" & i).Value = 0 Then 
       If delRange Is Nothing Then 
        Set delRange = .Range("P" & i) 
       Else 
        Set delRange = Union(delRange, .Range("P" & i)) 
       End If 
      End If 
     Next 
    End With 

    If Not delRange Is Nothing Then delRange.Delete shift:=xlUp 
    Application.ScreenUpdating = True 
End Sub 

Answer 1

Пробуйте приведенный ниже код. Проблема заключается в том, что ваша фактическая команда удаления не находится в цикле, но в конце. Так что это происходит только один раз. Кроме того, Union() не требуется.

Sub Sample() 

Dim lRow, i As Long 
Dim ws As Worksheet 
Dim delRange As Range 
'~~> Change this to the relevant worksheet 
Set ws = ThisWorkbook.Sheets("Sheet1") 

Application.ScreenUpdating = False 

With ws 
    lRow = .Range("P" & .Rows.Count).End(xlUp).Row 
    For i = lRow To 7 Step -1 
     If .Range("P" & i).Value <> "" And .Range("P" & i).Value = 0 Then 
      .Range("P" & i).Delete shift:=xlUp 
     End If 
    Next 
End With 

Application.ScreenUpdating = True 
End Sub 

Что такое .delete объединенного диапазона ...?

Answer 2

Попробуйте это:

Sub ZeroKiller() 
    Dim rKill As Range 
    Set rKill = Nothing 
    For Each r In ActiveSheet.UsedRange 
     If r.Value = 0 And r.Value <> "" Then 
      If rKill Is Nothing Then 
       Set rKill = r 
      Else 
       Set rKill = Union(rKill, r) 
      End If 
     End If 
    Next r 

    If rKill Is Nothing Then 
    Else 
    rKill.Delete Shift:=xlUp 
    End If 
End Sub