Question

我需要一个代码，允许我根据匹配的ID复制和粘贴信息。问题是我的工作表所拥有的行数超过200000行，每行都有ID。在表2中重复了一些ID。我只设法创建一个代码，但它似乎正在运行然后崩溃。表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

我遇到了同样的问题，并且能够通过在重新分配变量cellFound之前解除分配它来解决它。所以，我建议你添加：

Set cellFound  = Nothing

在End If之后。

希望有所帮助。

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

1 个答案: