VBA - looking through each record

问题

Struggling a bit with this code, I haven't ever had to reference one column and copy and paste to another tab in VBA so here goes..

I have an excel document with a table on it similar to below:

I need my code to look in column A find the first name, in this case, Nicola. I then want it to look at column B and check to see if she has the word "Internet" appear in any of the records stored against her, as she does the code will ignore her and move down to the next name on the list, in this case, Graham. It will then look to column B and check if he has the word "Internet". As he doesn't, the code needs to copy the Information from column A & B in relation to this persons name and paste the information into another sheet in the workbook.

    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

Any help would be greatly appreciated. Thanks

Paula

回答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

回答2:

I don't clearly see the structure of your data, but assuming the original data is in Worksheet Data, I think the following is going to do what you want (edited to search for two conditions).

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

来源：https://stackoverflow.com/questions/35725087/vba-looking-through-each-record