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

您错过了Next的{​​{1}}语句。 这两个标准可以与这一行一起使用：

each loop

所以整个代码都是......

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

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

 Public Function InsertData(ds As DataSet) As Boolean
    Dim cmd As New SqlCommand
    Dim cmd1 As New SqlCommand
    Dim status As Boolean
    Dim name As String
    Dim poc As String

    Dim id_p As New SqlParameter("id", SqlDbType.VarChar)
    Dim name_p As New SqlParameter("name", SqlDbType.VarChar)

    cmd.Parameters.Add(id_p)
    cmd.Parameters.Add(name_p)

    For i = 0 To ds.Tables(0).Rows.Count - 1

        If checkExists(ds.Tables(0).Rows(i)(1).ToString(), ds.Tables(0).Rows(i)(2).ToString(), ds.Tables(0).Rows(i)(3).ToString()) = True Then


            name = ds.Tables(0).Rows(i)(1).ToString()
            poc = ds.Tables(0).Rows(i)(2).ToString()

            If name.Contains("'") Then
                name = name.Replace("'", "''")
            End If
            If poc.Contains("'") Then
                poc = poc.Replace("'", "'")
            End If

            name_p.SqlValue = name
            id_p.SqlValue = poc


            cmd.CommandText = "INSERT INTO Code (Name,ID)" _
                              & " VALUES (@name,@id)"

            status = ExecuteNonQuerybySQLCommand(cmd)
        End If
    Next

    Return status

End Function


Dim strcon As String = "Data Source=x.x.x.x,1433;Network Library=DBMSSOCN;Initial Catalog=code_DB;User ID=xxx;Password=xxx;"

 Public Function ExecuteNonQuerybySQLCommand(ByVal cmd As SqlCommand) As Boolean
    Dim sqlcon As New SqlConnection
    Dim i As Integer = 0

    sqlcon.ConnectionString = strcon
    cmd.Connection = sqlcon

    Try
        sqlcon.Open()
        i = cmd.ExecuteNonQuery()
        sqlcon.Close()

        If i > 0 Then
            Return True
        Else
            Return False
        End If

    Catch ex As Exception
        Console.Write(ex)
        Return False
    End Try
End Function

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