VBA Если с двумя критериями в двух столбцах

Мне нужно посмотреть на две ячейки (C и F) в каждой строке, и если значение для C заканчивается на 30, а значение F больше нуля, скопируйте и вставьте строку на другой лист. Мне удалось получить копию и вставку для работы с использованием 1 критерия, но я не могу понять, как заставить оба критерия работать вместе.VBA Если с двумя критериями в двух столбцах

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

источник

2016-11-09 J.Zentner

Вы сказали, что ответ на ваш вопрос , но я бы использовал что-то в вашей прокомментированной строке: 'If Right (x, 2) =" 30 "И x.offset (0,3) .value> 0 Then' –

Ваш диапазон неправильный, вам нужно только C в там смещение перемещается в F и снова использует X, а не ячейку для сравнения значений = «30». –

@Nathan_Sav Спасибо. Исправлено и теперь работает !! –

Здесь вы идете:

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, чтобы подсчитать число строк и, следовательно, предполагается, что это основная колонка

источник

2016-11-09 12:04:18 user1

Данные начинаются с Col A и заканчиваются Col L, мне нужна вся строка, скопированная, если критерии удовлетворяются, а не только две ячейки. –

Вы отсутствовали в Next заявление в вашей второй для each loop. Две критерии могут быть взяты вместе с этой линией:

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

источник

2016-11-09 09:54:45 rohrl77

Чтобы ускорить процесс, я хотел бы предложить следующее:

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

источник

2016-11-09 10:06:06 Jeremy

Дальнейшее повышение производительности будет заключаться в использовании массивов, поэтому 'arr1 = range (c1: c100) .value',' arr1 = range (f1: f100) .value', затем сгруппируйте массивы –

@Nathan_Sav. Хотя массивы обычно являются хороший способ улучшить производительность, я не думаю, что это имеет место здесь (счастлив быть исправленным) – Jeremy

массив 16 мс, диапазон 31 мс в моем тесте 7000 строк :) –

Попробуйте этот код один раз - это слишком простая и оптимизированная обработка, чем циклы (медленнее)

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

источник

2016-11-09 10:11:47

Если я заменю x = cell.Value If Right(x,2)="30"Then ForEach cell1 In rSearch1y = cell1.Value If y >0Then на If Right(cell, 2) = "30" And cell.Offset(, 3) > 0 Then, тогда он правильно опускает строки, где значение в столбце F отрицательно, однако оно вытягивает значения, где последние две цифры в Col F случаются 30. Мне нужно, чтобы только две последние цифры Col C были равны 30, а Col больше 0. –

Запустил мой код, это делает именно то, что вам нужно. –

Все, что он сделал, это добавить фильтр в Col C без выбора. –

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

источник

2016-11-09 10:46:38

Это займет некоторое время, так как проверяет каждую строку в вашей книге. – Jeremy

Вам следует избегать '.Выбирайте инструкции любой ценой, поскольку она медленнее и с большей вероятностью возникновения ошибок. Вы также должны получить свою последнюю строку с информацией, так как цикл всех строк до конца не очень эффективен ... – RCaetano

@Jeremy, есть ли у вас какие-либо другие предложения о том, как я могу сделать это быстрее? Мне удалось заставить весь код работать и вставлять, когда мне нужно, где он мне нужен, но вы оба правы, ему нужно и возраст для запуска. –

Вот здесь весь код. Он работает, но требуется много времени для запуска. Любая помощь, чтобы ускорить это, будет оценена по достоинству.

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

источник

2016-11-09 11:13:39

VBA Если с двумя критериями в двух столбцах

ответ

Смежные вопросы