Question

使用此代码苦苦挣扎，我还没有必要引用一个列并复制并粘贴到VBA中的另一个选项卡，所以这里就是..

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

我需要我的代码在A列中找到第一个名字，在本例中是Nicola。然后，我想让它看一下B栏并检查她是否有“＃34; Internet＆＃34;出现在她存储的任何记录中，因为代码将忽略她并向下移动到列表中的下一个名称，在本例中为Graham。然后它将查看B列并检查他是否有“＃34; Internet＆＃34;”这个词。正如他所做的那样，代码需要复制A＆amp; 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()
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

Answer 2

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

VBA - 浏览每条记录

2 个答案: