我必须根据 Headers 和匹配ID将特定列数据从Sheet1复制到Sheet2 . 预期的宏必须遍历列A（Sheet1），匹配A列（Sheet2）中的ID，并将特定列数据与Sheet1中的 Headers 匹配，并将其与Sheet2中的 Headers 相对应 .

表1和表2中的数据如下所示 . 我想为Sheet2中的每个ID复制Location，StartDate和EndDate .

SHEET1

Col A
BadgeID    Location    StartDate     EndDate
1111       AA1199      01/17/2016    03/17/2016
2222       BB2266      02/12/2016    05/25/2016
3333       CC5577      07/12/2016    09/15/2016

SHEET2

Col A
BadgeID    Location    StartDate     EndDate
1111       
2222
3333

我已经使用下面的代码根据预定义的匹配单元格值复制和粘贴整行，但是对于本练习，ID超过5000.任何帮助都将非常感激 .

Option Compare Text
Public Sub CompareandCopy()
Dim strFind As String
Dim i As Long, j As Long
Dim wsFind As Worksheet
Dim wsPaste As Worksheet

strFind = InputBox("Enter ID Here")
Set wsFind = Sheets("Sheet1")
Set wsPaste = Sheets("Sheet2")

j = 2

Worksheets("Sheet2").Range("A3:C10").ClearContents
For i = 2 To wsFind.UsedRange.Rows.Count
    If wsFind.Range("A" & i) = strFind Then
        wsFind.Range(i & ":" & i).Copy Destination:=wsPaste.Range(j & ":" & j)
        j = j + 1
    End If
Next i

Worksheets("Sheet2").Select
End Sub

谢谢

excel vba excel-vba