Question

我正在尝试使用Excel 2007为我收集的一些数据创建一个宏。我需要宏做的是，搜索一列并找到一定数量的连续零（60），如果有60个连续零则删除它们。任何建议或帮助都会非常感激！

Answer 1

这是你在尝试的吗？

<强> LOGIC ：

根据条件
将地址存储在变量
删除Excel自动放入地址的“$”
检查可见单元格地址是否为“2：2”或“2：2,5：64”
找出起始行和结束行之间的区别
如果差异为> = = 60，则清除内容。

<强> CODE

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, times As Long, Col As Long, i As Long
    Dim rRange As Range
    Dim addr As String, MyArray() As String, tmpAr() As String, num As String

    '~~> Change these as applicable
    Set ws = ThisWorkbook.Sheets("Sheet1")  '<~~ Sheet1
    Col = 1                                 '<~~ Col A
    num = "0"                               '<~~ Number to replace
    times = 60                              '<~~ Consecutive Cells with Numbers

    '~~> Don't change anything below this
    With ws
        lRow = .Range(ReturnName(Col) & .Rows.Count).End(xlUp).Row

        Set rRange = .Range(ReturnName(Col) & "1:" & ReturnName(Col) & lRow)

        '~~> Remove any filters
        .AutoFilterMode = False

        '~~> Filter, offset(to exclude headers)
        With rRange
          .AutoFilter Field:=1, Criteria1:="=" & num
          '~~> get the visible cells address
          addr = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Address
        End With

        '~~> Remove any filters
        .AutoFilterMode = False

        addr = Replace(addr, "$", "")

        '~~> Check if addr has multiple ranges
        If InStr(1, addr, ",") Then
            MyArray = Split(addr, ",")

            '~~> get individual ranges
            For i = LBound(MyArray) To UBound(MyArray)
                tmpAr = Split(MyArray(i), ":")

                '~~> If difference is >= times then clear contents
                If Val(Trim(tmpAr(1))) - Val(Trim(tmpAr(0))) >= times - 1 Then
                    .Range(ReturnName(Col) & Trim(tmpAr(0)) & ":" & _
                    ReturnName(Col) & Trim(tmpAr(1))).ClearContents
                End If
            Next i
        Else
            tmpAr = Split(addr, ":")

            If Val(Trim(tmpAr(1))) - Val(Trim(tmpAr(0))) >= times - 1 Then
                .Range(ReturnName(Col) & Trim(tmpAr(0)) & ":" & _
                ReturnName(Col) & Trim(tmpAr(1))).ClearContents
            End If
        End If
    End With
End Sub

'~~~> Function to retrieve Col Names from Col Numbers
Function ReturnName(ByVal numb As Long) As String
    ReturnName = Split(Cells(, numb).Address, "$")(1)
End Function

Answer 2

虽然我有一种感觉，但是在你运行之后你会改变要求......

选择要查看的所有单元格，然后运行以下代码：

Option Explicit

Sub deleteConsecutiveZeros()
    Dim rng As Excel.Range
    Dim countZeros As Long
    Dim lastCellRow As Long
    Dim iCurrentRow As Long

    Set rng = Selection
    lastCellRow = rng.Cells.SpecialCells(xlCellTypeLastCell).Row
    For iCurrentRow = lastCellRow To 1 Step -1
        If (countZeros >= 60) Then
            ActiveSheet.Range(rng.Cells(iCurrentRow + 59, 1).Address, rng.Cells(iCurrentRow, 1).Address).EntireRow.Delete
            countZeros = 0
        End If

        If (rng.Cells(iCurrentRow, 1).Value = 0 And rng.Cells(iCurrentRow, 1).Text <> vbNullString) Then
            countZeros = countZeros + 1
        Else
            countZeros = 0
        End If
    Next
End Sub

创建特定的宏

2 个答案: