Question

对于我正在处理的项目，我试图从excel电子表格中复制一行，但前提是符合正确的标准。

例如，

我需要复制一行中包含以下内容的行：

Fruit，Apple，True，Cell＆lt; 4

我尝试过使用像

这样的东西

Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch

Set SrchRng = ActiveSheet.Range("A4:T60", ActiveSheet.Range("A60:T60").End(xlUp))

For Each strSearch In Array("Apple")

    Set c = SrchRng.Find(strSearch, LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireRow.Copy
    Sheets("Results").Paste
Next strSearch


End Sub

但问题在于它只搜索一个标准：Apple。我需要脚本扫描整行，以便所有过滤器都正确，然后复制行。

我使用的脚本也只复制行一次，似乎不会复制包含Apple的所有行。

Answer 1

我假设您的数据是一致的，即您在一列中查找Fruit，在另一列中查找Apple，同样在TRUE和<4中查找。{br /> 我在代码中寻找Fruit in Column A，Apple in Column B，TRUE in Column C和<4 in Column D。您可以根据需要更改列号我已将数据命名为Data的工作表和将复制的行粘贴为Results的工作表

Sub CopyRow()
    Dim LastRowCurr As Long, LastRowResult As Long
    Dim LastColumn As Long
    Dim i As Long
    Dim currWS As Worksheet, resultWS As Worksheet
    Dim MyRange As Range

    Set currWS = ThisWorkbook.Sheets("Data")      '---> sheet where data is
    Set resultWS = ThisWorkbook.Sheets("Results") '---> sheet to paste copied rows

    lastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row
    LastRowResult = resultWS.Cells(Rows.Count, "A").End(xlUp).Row

    With currWS
        For i = 4 To lastRow
            'change column numbers in the below line as required
            If .Cells(i, 1).Value = "Fruit" And .Cells(i, 2).Value = "Apple" And .Cells(i, 3).Value = True And .Cells(i, 4).Value < 4 Then
                .Rows(i).Copy Destination:=resultWS.Range("A" & LastRowResult)
                LastRowResult = LastRowResult + 1
            End If
        Next i
    End With
End Sub

我想这就是你想要的。

Answer 2

你必须为.find函数添加另一个循环。在您的代码上，它只为 Apples 查找一次。你要做的是，你必须添加另一个循环并重复 .find 函数，直到你 .find 函数再次给你第一个匹配。尝试这样的事情：

Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Dim wsResults As Worksheet
Dim firstAddress
Set SrchRng = ActiveSheet.Range("A1:T60", ActiveSheet.Range("A60:T60").End(xlUp))

Set wsResults = ThisWorkbook.Worksheets("Results")

For Each strSearch In Array("Apple")


    Set c = SrchRng.Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.EntireRow.Copy wsResults.UsedRange.Cells(wsResults.UsedRange.Rows.Count + 1, 1)
            Set c = SrchRng.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
Next strSearch
End Sub

在Excel中复制符合相应过滤条件的行

2 个答案: