VBA 2つの列に2つの基準がある場合

Question

各行で2つのセル（CとF）を調べる必要があります。また、Cの値が30でFの値が0より大きい場合は、行を別のシートに貼り付けます。私は、コピーと貼り付けを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の文が欠落していました。 2つのcriteriasが、このラインと一緒に撮影することができます：

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