创build一个特定的macros

我正在尝试使用Excel 2007为我收集的一些数据创build一个macros。 我需要macros做的是，search一个列，并find一定数量的连续零（60），如果有60个连续的零删除它们。 任何意见或帮助将非常感激！

Answer 1

这是你正在尝试？

逻辑 ：

1. 过滤条件的范围
2. 将可见单元格中的地址存储在一个variables中
3. 删除Excel自动放入地址的“$”
4. 检查可见的单元格地址是否像“2：2”或“2：2,5：64”
5. find开始行和结束行之间的区别
6. 如果差异> =说60，然后清除内容。

码

 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

虽然我有一种感觉，你运行这个后会改变需求…

select你想看的所有单元格，然后运行下面的代码：

 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