值变化的搜索范围，如果找到则复制整行

Question

我是 VBA 的新手（新手约 4 天），我尝试通过阅读大量关于此类资源的不同帖子并进行试验，以我通常的方法解决这个问题，但还没有能够完全掌握它。我希望你们这些好人愿意指出我哪里出了问题。我已经看过很多（全部？）具有类似问题的线程，但无法从中拼凑出适合自己的解决方案。如果已经在其他地方回答过，希望您能原谅。

上下文：

我有一个电子表格，其中包含 B 列下方第 5-713 行中的项目（合并到单元格 J），其中对于每个日期（K-SP 列），该项目的得分为 1 或 0。我的目标是在工作表底部创建一个列表，其中包含从 1 变为 0 的所有项目。首先，我一直在尝试让我的 "generate list" 按钮复制所有带有 0 的行他们到底部，我想我以后会调整它来做我想做的。我已经尝试了几种方法并遇到了几种不同的错误。

Worksheet Sample 直观地了解我在说什么。

我经历了几次不同的尝试，每次都取得了有限的成功，通常每次都会遇到不同的错误。我有 "method 'range of object' _Worksheet failed"、"object required"、"type mismatch"、"out of memory" 和其他几个。我确定我只是没有掌握一些基本语法，这导致了一些问题。

这是最新的一批代码，给我报错'type mismatch'。我也试过让 'todo' 成为字符串，但那只是 'object required'

Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer, todo As Range

Set todo = ThisWorkbook.ActiveSheet.Range(Cells(5, 2), Cells(713, 510))

y = 5
z = 714
With todo
    Do
        If todo.Rows(y).Value = 0 Then
        todo.Copy Range(Cells(z, 2))
        y = y + 1
        z = z + 1
        End If
    Loop Until y = 708
End With


Application.ScreenUpdating = True
End Sub

另一个我认为很有希望的尝试如下，但它给了我 'out of memory'。

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer

y = 5
z = 714

Do
    If Range("By:SPy").Value = 0 Then
    Range("By:SPy").Copy Range("Bz")
    y = y + 1
    z = z + 1
    End If
Loop Until y = 708

Application.ScreenUpdating = True
End Sub

重申一下，我发布的代码尝试只是将包含 0 的任何行放到电子表格的底部，但是，如果有一种方法可以定义搜索 1 变为 0 的条件，那么太棒了！另外，我不确定如何区分实际数据中的 0 和项目名称中的零（例如，仅仅因为 10 是 1 就让 'Item 10' 进入列表并不是很好0 之后）。

任何有助于弄清楚这第一步的帮助，或者甚至如何让它扫描 1 变成 0 的帮助，我们都将非常感激。我确定我遗漏了一些简单的东西，希望你们能原谅我的无知。

谢谢！

Answer 1

这将查看数据并将其复制到数据的最后一行下方。假设数据下方没有任何内容。它也只查找零在找到 1.

之后

Sub findValueChange()

    Dim lastRow As Long, copyRow As Long, lastCol As Long
    Dim myCell As Range, myRange As Range, dataCell As Range, data As Range
    Dim hasOne As Boolean, switchToZero As Boolean
    Dim dataSht As Worksheet




    Set dataSht = Sheets("Sheet1") '<---- change for whatever your sheet name is

    'Get the last row and column of the sheet
    lastRow = dataSht.Cells(Rows.Count, 2).End(xlUp).row
    lastCol = dataSht.Cells(5, Columns.Count).End(xlToLeft).Column

    'Where we are copying the rows to (2 after last row initially)
    copyRow = lastRow + 2

    'Set the range of the items to loop through
    With dataSht
        Set myRange = .Range(.Cells(5, 2), .Cells(lastRow, 2))
    End With

    'start looping through the items
    For Each myCell In myRange
        hasOne = False 'This and the one following are just flags for logic
        switchToZero = False
        With dataSht
            'Get the range of the data (1's and/or 0's in the row we are looking at
            Set data = .Range(.Cells(myCell.row, 11), .Cells(myCell.row, lastCol))
        End With
        'loop through (from left to right) the binary data
        For Each dataCell In data
            'See if we have encountered a one yet
            If Not hasOne Then 'if not:
                If dataCell.Value = "1" Then
                    hasOne = True 'Yay! we found a 1!
                End If
            Else 'We already have a one, see if the new cell is 0
                If dataCell.Value = "0" Then 'if 0:
                    switchToZero = True 'Now we have a zero
                    Exit For 'No need to continue looking, we know we already changed
                End If
            End If
        Next dataCell 'move over to the next peice of data

        If switchToZero Then 'If we did find a switch to zero:
            'Copy and paste whole row down
            myCell.EntireRow.Copy
            dataSht.Cells(copyRow, 2).EntireRow.PasteSpecial xlPasteAll
            Application.CutCopyMode = False
            copyRow = copyRow + 1 'increment copy row to not overwrite
        End If

    Next myCell


    'housekeeping
    Set dataSht = Nothing
    Set myRange = Nothing
    Set myCell = Nothing
    Set data = Nothing
    Set dataCell = Nothing


End Sub

值变化的搜索范围，如果找到则复制整行

Search Range for Value Change, Copy Whole Row if Found

excel

search

vba

criteria