Excel Vba - 如果满足该值，则将数据复制/链接到另一个工作表

Question

我是VBA的新手。它有任何方式连接表2和表1.请参见下图：

表1

表2

我尝试使用这个VBA代码，但它不起作用。

Sub Finddata()  
Dim x As Long  
Sheets("Sheet2").Activate  
For x = 2 To    Sheets("Sheet2").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count  
For y = 2 To 5  

On Error Resume Next  
Cells(x, y).Value = Application.WorksheetFunction.VLookup(Cells(x, "A").Value, Sheets("Sheet1").Range("A2:F18"), y = 1, 0)  
Next y  
Next x  

End Sub  

Answer 1

如下所示，这使用.Find方法在Sheet1中搜索给定值，然后通过offsetting返回：

Sub Finddata()
Dim x As Long, LastRow As Long
Dim FindValues As Range
Dim ws As Worksheet: ws = Sheets("Sheet1")
Dim ws2 As Worksheet: ws2 = Sheets("Sheet2")
'above declare variables

LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Sheet2
For x = 2 To LastRow 'loop from row 2 to last on Sheet2
    Set FindValues = ws.Range("A:A").Find(What:=ws2.Cells(x, 1).Value, Lookat:=xlWhole)
    'use the Find method to search for the value in Sheet1
    If Not FindValues Is Nothing Then 'if found
        ws2.Cells(x, 2).Value = FindValues.Offset(0, 1).Value
        ws2.Cells(x, 3).Value = FindValues.Offset(0, 2).Value
        ws2.Cells(x, 4).Value = FindValues.Offset(0, 3).Value
        ws2.Cells(x, 5).Value = FindValues.Offset(0, 4).Value
        ws2.Cells(x, 6).Value = FindValues.Offset(0, 5).Value
        'pass the values into Sheet2
    End If
Next x
End Sub