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