Deleting consecutive values only if they exceed a certain number of occurrences

I'm working with a large spreadsheet. It consists of physical activity values, ranging from 0 to several thousand per minute.
My task is to delete values of 'non-wear time', which means deleting consecutive values of 10 or more "0's". But not if there is 9 or less. Is there any function or macro that can do this automatically?

I've added a photo as an example, showing a marking of cells that are to be deleted, while underneath there are cells that should not be deleted. Any help on the matter would save me a ton of hours.

example.png

You can try this on a copy of your workbook.

Sub AAAAA()
Dim i As Long, j As Long, ii As Long, a As Long, lr As Long, lc As Long
'This assumes that the last used column can be determined from the top row.
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
    For j = 1 To lc
    lr = Cells(Rows.Count, j).End(xlUp).Row
        For i = 1 To lr - 10
            If WorksheetFunction.CountIf(Range(Cells(i, j), Cells(i + 9, j)), Cells(i, j).Value) >= 10 Then
                ii = i
                a = 0
                    Do
                        If Cells(ii, j).Value = 0 Then a = a + 1: ii = ii + 1
                    Loop Until Cells(ii, j).Value <> 0
                Range(Cells(i, j), Cells(i + a - 1, j)).Delete Shift:=xlUp
            End If
        Next i
    Next j
Application.ScreenUpdating = True
End Sub

This might be better.

Sub AAAAM()
Dim i As Long, j As Long, lc As Long, k As Long
Application.ScreenUpdating = False
lc = Cells(1, Columns.Count).End(xlToLeft).Column
    For k = 1 To lc
        For i = Cells(Rows.Count, k).End(xlUp).Row To 2 Step -1
            If Cells(i, k).Value = 0 Then
                j = j + 1
                    If j > 9 And Cells(i, k).Offset(-1).Value <> 0 Then Range(Cells(i, k), Cells(i + j - 1, k)).Delete Shift:=xlUp
                        Else
                j = 0
            End If
        Next i
    Next k
End Sub

Hi

Thanks for the replies. I’m still having difficulties with the proposed methods, and they are too advanced for me to successfully debug (I’ve tried )

So I will simplify the problem. In a single column of numbers, I need 10 or more consecutive 0’-s deleted. I’ve added two pictures showing before and after.

It would be preferable if this operation could be performed on the selected cells only, but not crucial.

1.png2.png

How about

Sub delTenZeros()
   Dim Rng As Range
   With Selection
      .Replace 0, True, xlWhole, , , , False, False
      For Each Rng In .SpecialCells(xlConstants, xlLogical).Areas
         If Rng.count >= 10 Then Rng.ClearContents Else Rng = 0
      Next Rng
   End With
End Sub

Perfect! The rest I can handle myself. Thanks a lot

Glad to help 7 thanks for the feedback