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的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