Question

我编写了以下代码，以在数据列中循环查找“个人”或“欺诈”之类的关键字，并将带有这些关键字的行复制到单独的标签中。

当关键字在词组内（例如“个人开支”）时，我的代码不匹配。

Sub pooling()

a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
    If Worksheets("Sheet1").Cells(i, 10).Text = "Personal" Or _
         Worksheets("Sheet1").Cells(i, 10).Text = "Fraud" Then
         Worksheets("Sheet1").Rows(i).Copy
         Worksheets("Sheet2").Activate
         b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
         Worksheets("Sheet2").Cells(b + 1, 1).Select
         ActiveSheet.Paste
         Worksheets("sheet1").Activate
    End If    
Next

End Sub

Answer 1

尝试使用Like和通配符*，如下面的代码所示：

If Worksheets("Sheet1").Cells(i, 10).Value2 Like "*" & "Personal" & "*" Or _
         Worksheets("Sheet1").Cells(i, 10).Value2 Like "*" & "Fraud" & "*" Then

完整修改的较短代码版本（不使用Activate）

Sub pooling()

Application.ScreenUpdating = False  ' turn off screen updating >> accelerate run time

With Worksheets("Sheet1")
    a = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 2 To a
        If .Cells(i, 10).Value2 Like "*" & "Personal" & "*" Or _
             .Cells(i, 10).Value2 Like "*" & "Fraud" & "*" Then

             ' find last row in "Sheet2"
             b = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Row

             ' copy>>paste is a 1-line syntax
             .Rows(i).Copy Destination:=Worksheets("Sheet2").Cells(b + 1, 1)
        End If
    Next i
End With

Application.ScreenUpdating = True

End Sub

Answer 2

我认为最好使用AutoFilter()：

Sub pooling()
    With Worksheets("Sheet1") ' reference "Sheet1" sheet
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) ' reference referenced sheet column A range from row 1 (header) to last not empty cell
            .AutoFilter field:=1, Criteria1:="*Personal*", Operator:=xlOr, Criteria2:="*Fraud*" ' filter referenced range with wanted criteria
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) ' reference referenced range offsetted one row down to skip headers
                If CBool(Application.Subtotal(103, .Cells)) Then .SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Offset(1) ' if any filtered cells then copy their entire row and paste them to "Sheet2" starting from its column A first empty row after last not empty one
            End With
        End With
        .AutoFilterMode = False
    End With
End Sub

在短语中搜索单词

2 个答案: