VBA如果在两列中包含两个条件

Question

我需要查看每行上的两个单元格（C和F），如果C的值以30结尾并且F的值大于零，请将行复制并粘贴到另一张纸上。 我已经设法使用1个条件来完成复制和粘贴，但是我无法弄清楚如何使两个条件一起工作。

Sub compile1()
    Dim x As String

Set rSearch = Sheets("Application").Range("C:C")


For Each cell In rSearch
x = cell.Value
       If Right(cell, 2) = "30" And cell.Offset(, 3) > 0 Then

        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets("sheet2").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Application").Select
    End If

Next

End Sub

Answer 1

干得好：

Sub CP()

Dim i As Long
Dim n As Long

n = Sheets("Application").Cells(Rows.Count, 3).End(xlUp).Row

For i = 1 To n
    With Sheets("Application")
        If Right(Cells(i, 3), 2) = 30 And Cells(i, 6).Value > 0 Then
            .Cells(i, 3).EntireRow.Copy Destination:=Sheets("Sheet3").Cells(i, 3)
            .Cells(i, 6).EntireRow.Copy Destination:=Sheets("Sheet3").Cells(i, 6)
        End If
    End With
Next i

End Sub

我已经使用第3列来计算行数，因此假设这是主列

Answer 2

对于each loop ，您each loop在第二秒中丢失了Next语句。 这两个条件可以与此行一起使用：

If y > 0 And Right(x, 2) = "30" Then

因此整个代码将是...

Sub compile1()
Dim x As String
Dim y As Integer
Dim rSearch As Range
Dim rSearch1 As Range
Dim cell As Range, cell1 As Range
Dim matchRow As Integer

Set rSearch = Sheets("Application").Range("C:c")
Set rSearch1 = Sheets("Application").Range("F:F")

For Each cell In rSearch
    x = cell.Value
    For Each cell1 In rSearch1
    y = cell1.Value
        If y > 0 And Right(x, 2) = "30" Then
            matchRow = cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy

            Sheets("sheet2").Select
            ActiveSheet.Rows(matchRow).Select
            ActiveSheet.Paste
            Sheets("Application").Select
        End If
    Next cell1
Next cell

End Sub

Answer 3

为了加快速度，我建议以下几点：

Sub Copy_Paste()
Dim x As String
Dim y As Integer
Dim WS1 As Worksheet

Set WS1 = ActiveSheet
y = 1
Do Until y > WorksheetFunction.Max(Range("C1048576").End(xlUp).Row, Range("F1048576").End(xlUp).Row)
    x = Trim(Cells(y, 3).Value)
    If Right(x, 2) = "30" And (IsNumeric(Cells(y, 6).Value) And Cells(y, 6).Value > 0) Then Rows(y & ":" & y).Copy: Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("C1048576").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False: Application.CutCopyMode = False
    y = y + 1
Loop

Sheets("Sheet2").Activate
Range("A1").Activate
WS1.Activate

End Sub

Answer 4

尝试一次此代码-这比循环（更慢）比简化和优化处理的方式还要多

Application.ScreenUpdating = False
Application.EnableEvents = False

Sheets("Application").AutoFilterMode = False

Dim lastrow, lastcol As Integer
lastrow = Range("F500000").End(xlUp).Row
lastcol = Sheets("Application").Range("A1").End(xlToRight).Column + 1

Sheets("Application").Cells(1, lastcol).Value = "helper"
Sheets("Application").Range(Sheets("Application").Cells(1, lastcol),Sheets("Application").Cells(lastrow, lastcol)).FormulaR1C1 = "=Right(RC[-1],2)"

Sheets("Application").Range(Range("A1"), Range("A1").End(xlToRight)).AutoFilter Field:=lastcol, Criteria1:="30"
Sheets("Application").Range(Range("A1"), Range("A1").End(xlToRight)).AutoFilter Field:=3, Criteria1:=">0"

Sheets("Application").Range(Cells(1, 1), Cells(lastrow, lastcol)).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheet2.Range("A2")

Columns(lastcol).Delete

Application.ScreenUpdating = True
Application.EnableEvents = True

Answer 5

Sub compile1()
Dim Cel As Range, Rng As Range

Set rSearch = Sheets("Application").Columns("C:C").SpecialCells(xlCellTypeConstants, 23)

For Each Cel In rSearch
   If Right(Trim(Cel.Value), 2) = "30" And (Cel.Offset(, 3).Value > 0) Then
        Cel.EntireRow.Copy
        Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("C1048576").End(xlUp).Row + 1).Paste
        Application.CutCopyMode = False
    End If
Next

End Sub

Answer 6

这是完整的代码。 它可以工作，但是要花很多时间才能运行。 任何帮助加快速度将不胜感激。

Sub Master()
Call compile1
Call compile2
End Sub
Sub compile1()
For Each cell In Sheets("Application").Range("C:C")
    If Right(cell.Value, 2) = "10" Then
        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets("Routine w credits").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Application").Select
    End If
Next

For Each cell In Sheets("Application").Range("C:C")
    If Right(cell.Value, 2) = "20" Then
        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets("Reactive w credits").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Application").Select
    End If
Next

End Sub

Sub compile2()

Set rSearch = Sheets("Application").Range("C:C")

For Each cell In rSearch

   If Right(cell, 2) = "20" And cell.Offset(, 3) > 0 Then

        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets("Reactive wo credits").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Application").Select
    End If

Next

For Each cell In rSearch

   If Right(cell, 2) = "10" And cell.Offset(, 3) > 0 Then

        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets("Routine wo credits").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Application").Select
    End If

Next
End Sub