excel - 特定のマクロの作成

Question

収集したデータに対して Excel 2007 を使用してマクロを作成しようとしています。マクロで必要なことは、列を検索して一定数 (60) の連続するゼロを見つけ、60 個の連続するゼロがある場合はそれらを削除することです。アドバイスや助けをいただければ幸いです。

Answer 1

これはあなたがしようとしていることですか？

ロジック:

1. 基準で範囲をフィルタリングする
2. 可視セルのアドレスを変数に格納する
3. アドレスにExcelが自動で入れる「$」を削除
4. 表示されているセル アドレスが「2:2」または「2:2,5:64」のようになっているかどうかを確認します
5. 開始行と終了行の違いを見つける
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

これを実行した後、要件を変更する気がしますが...

確認したいすべてのセルを選択してから、次のコードを実行します。

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