0

我编写了以下代码来循环遍历“个人”或“欺诈”等关键字的数据列，并将带有这些关键字的行复制到单独的选项卡中。

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

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
4

2 回答 2

0

尝试使用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
于 2018-10-01T00:24:06.527 回答
0

我认为最好是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
于 2018-10-01T06:18:13.310 回答