VBA - просматривая каждую запись

Question

Борясь немного с этим кодом, я никогда не должен был ссылаться на один столбец и скопировать и вставить на другую вкладку в VBA, так что здесь идет ..

У меня есть документ первенствовать с таблица на него похожа ниже:

Мне нужен мой код, чтобы посмотреть в колонке А найти имя, в этом случае, Nicola. Затем я хочу, чтобы он посмотрел на столбец B и посмотрел, есть ли у нее слово «Интернет» в любой из записей, хранящихся на ней, так как она будет игнорировать ее и перейти к следующему имени в списке, в этом случае, Грэхем. Затем он посмотрит на столбец B и проверит, есть ли у него слово «Интернет». Поскольку он этого не делает, код должен скопировать информацию из колонки A & B в отношении этого лица и вставить информацию на другой лист в книге.

Sub Test3() 
    Dim x As String 
    Dim found As Boolean 
    Range("B2").Select 
    x = "Internet" 
    found = False 
    Do Until IsEmpty(ActiveCell) 
    If ActiveCell.Value = x Then 
     found = True 
     Exit Do 
    End If 
    ActiveCell.Offset(1, 0).Select 
    Loop 
    If found = False Then 
    Sheets("Groupings").Activate 
    Sheets("Groupings").Range("A:B").Select 
    Selection.Copy 
    Sheets("Sheet1").Select 
    Sheets("Sheet1").Range("A:B").PasteSpecial 

    End If 
    End Sub 

Любая помощь была бы принята с благодарностью. Благодаря

Paula

Answer 1

Private Sub Test3() 
Application.ScreenUpdating = False 

Set sh1 = Sheets("Groupings") 'data sheet 
Set sh2 = Sheets("Sheet1") 'paste sheet 

myVar = sh1.Range("D1") 

Lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row 

For i = 2 To Lastrow '2 being the first row to test 
If Len(sh1.Range("A" & i)) > 0 Then 
    Set myFind = Nothing 

    If WorksheetFunction.CountA(sh1.Range("A" & i, "A" & Lastrow)) > 1 Then 
     If Len(sh1.Range("A" & i + 1)) = 0 Then 
      nextrow = sh1.Range("A" & i).End(xlDown).Row - 1 
     Else 
      nextrow = nextrow + 1 
     End If 
      Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole) 

    Else 
     nextrow = Lastrow 
     Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole) 


    End If 

    If myFind Is Nothing Then 
     sh1.Range("A" & i, "B" & nextrow).Copy 
     sh2.Range("A" & sh2.Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues 
     Application.CutCopyMode = False 
    End If 
End If 
Next 
End Sub 

Answer 2

Я не ясно видеть структуру данных, но предполагая, что исходные данные в рабочем листе данных, я думаю, что следующее будем делать то, что вы хотите (отредактированный для поиска два условия).

Private Sub Test3() 
Dim lLastRow as Long 
Dim a as Integer 
Dim i as Integer 
Dim sText1 As String 
Dim sText2 As String 

sText1 = Worksheets("Data").Cells(1, 5).Value 'search text #1, typed in E1 
sText2 = Worksheets("Data").Cells(2, 5).Value 'search text #2, typed in E2 

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 
a = 1 
For i = 2 To lLastRow 
    If (Worksheets("Data").Cells(i, 1).Value <> "") Then 
     If (Worksheets("Data").Cells(i, 2).Value <> sText1 And Worksheets("Data").Cells(i + 1, 2).Value <> sText1 And Worksheets("Data").Cells(i, 2).Value <> sText2 And Worksheets("Data").Cells(i + 1, 2).Value <> sText2) Then 
      Worksheets("Groupings").Cells(a, 1).Value = Worksheets("Data").Cells(i, 1).Value 
      Worksheets("Groupings").Cells(a, 2).Value = Worksheets("Data").Cells(i, 2).Value 
      Worksheets("Groupings").Cells(a, 3).Value = Worksheets("Data").Cells(i + 1, 2).Value 
      a = a + 1 
     End If 
    End If 
Next 
End Sub