根据匹配的ID，将信息从一个工作表复制并粘贴到工作簿中的另一个工作表中

我需要一个代码，允许我复制和粘贴基于匹配的ID的信息。 问题是，我的工作表所在的行数多于200000行，每行都有ID。 一些ID在表2中重复。我只能设法创build一个代码，但它似乎在运行，然后崩溃。 工作表2由所有信息组成，而工作表1是当两张工作表的ID匹配时，信息将被粘贴的位置。 这是迄今为止的代码。 我真的希望任何人都可以帮助我，因为这段代码似乎继续运行和崩溃，我的VBA技能是非常有限的，

Sub AAA() Dim tracker As Worksheet Dim master As Worksheet Dim cell As Range Dim cellFound As Range Dim OutPut As Integer Set tracker = Workbooks("test.xlsm").Sheets("Sheet1") Set master = Workbooks("test.xlsm").Sheets("Sheet2") For Each cell In master.Range("A2:A100000") ' Try to find this value in the source sheet Set cellFound = tracker.Range("A5:A100000").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not cellFound Is Nothing Then ' A matching value was found ' So copy the cell 2 columns across to the cell adjacent to matching value ' Do a "normal" copy & paste cellFound.Offset(ColumnOffset:=2).Value2 = cell.Offset(ColumnOffset:=2).Value2 ' Or do a copy & paste special values 'cell.Offset(ColumnOffset:=2).Copy 'cellFound.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues Else ' The value in this cell does not exist in the source ' Should anything be done? End If Next OutPut = MsgBox("Update over!", vbOKOnly, "Update Status") End Sub 

Answer 1

我有同样的问题，并能够解决它通过释放variablescellFound重新分配之前。 所以，我build议你增加：

 Set cellFound = Nothing 

End If 。

希望有所帮助。