VBA - 通过每个记录

Question

挣扎了一下这个代码看，我还没有过引用一列在VBA复制并粘贴到另一个选项卡，以便在这里不用..

我有一个excel文件上表类似如下：

我需要我的代码看起来在A列中找到的第一个名字，在这种情况下，尼古拉。然后我想让它看看B列，并检查她是否在存储的任何记录中出现了“Internet”字样，因为她的代码会忽略她并移动到列表中的下一个名称，在这种情况下，格雷厄姆。然后它会查看B列并检查他是否有“Internet”一词。因为他没有，代码需要复制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 

任何帮助将不胜感激。 感谢

保

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