Excel VBA-查看每个记录

这段代码让我有点纠结，我从来没有在VBA中引用过一列并复制粘贴到另一个选项卡上，所以我就这样做了

我有一个excel文档，上面有一个类似以下的表格：

我需要我的代码在A列中查找名字，在本例中为Nicola。然后我想让它看看B列，看看她是否有“互联网”这个词出现在任何针对她的记录中，当她这样做时，代码将忽略她，并向下移动到列表上的下一个名字，在本例中是Graham。然后它会查看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

我不清楚您的数据结构，但假设原始数据在工作表数据中，我认为下面将执行您想要的操作（编辑以搜索两个条件）

Private子测试3（）
昏暗的灯塔一样长
将a变暗为整数
作为整数的Dim i
Dim sText1作为字符串
Dim sText2作为字符串
sText1=工作表（“数据”）。单元格（1，5）。值“搜索文本”1，键入E1
sText2=工作表（“数据”）。单元格（2，5）。值“搜索文本”2，键入E2
lLastRow=单元格（Rows.Count，1）.End（xlUp）.Row
a=1
对于i=2至lLastRow
如果（工作表（“数据”）.Cells（i，1）.Value“”），则
如果（工作表（“数据”）.单元格（i，2）.值sText1和工作表（“数据”）.单元格（i+1，2）.值sText1和工作表（“数据”）.单元格（i，2）.值sText2和工作表（“数据”）.单元格（i+1，2）.值sText2），则
工作表（“分组”）。单元格（a，1）。值=工作表（“数据”）。单元格（i，1）。值
工作表（“分组”）。单元格（a，2）。值=工作表（“数据”）。单元格（i，2）。值
工作表（“分组”）。单元格（a，3）。值=工作表（“数据”）。单元格（i+1，2）。值
a=a+1
如果结束
如果结束
下一个
端接头

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

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