将行从一个表复制到另一个表而不创build重复项

我有一个Excel工作簿，它具有一个跟踪项目和当前位置的主表单，以及另一个跟踪过去位置或项目位置的表单。 当前当主表单中的logging被更改时，该行被手动复制并粘贴到第二张表中。 我想要创build一个macros，它将查找主表单中不在第二张表中的项目，并在logging更改时将其复制到第二张表格中。

下面是一个我发现并修改的示例macros，但是它复制并粘贴所有行，而不是新的或不同的行。 只需要在列A，B和D上比较行。

Public Sub Sample() Dim shM As Worksheet, sh2 As Worksheet Dim shMData As Variant Dim sh2DataA As Variant Dim sh2Data As Variant Dim iM As Long, os2 As Long, i2 As Variant Dim DoSearch As Boolean Set shM = Sheets(1) Set sh2 = Sheets(2) With shM shMData = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4) End With DoSearch = False For iM = 2 To UBound(shMData, 1) With sh2 sh2DataA = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 1) sh2Data = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4) End With os2 = 0 Do If UBound(shMData, 1) > 1 Then i2 = Application.Match(shMData(iM, 1), sh2DataA, 0) Else If shMData(iM, 1) = sh2DataA Then i2 = 1 Else i2 = CVErr(xlErrNA) End If End If If Not IsError(i2) Then If (shMData(iM, 2) = sh2Data(i2, 2)) And (shMData(iM, 4) = sh2Data(i2, 4)) Then MsgBox "Match found Master = " & iM & ", sheet2 = " & i2 + os2 Else shM.Activate shM.Range(Cells(iM, 1), Cells(iM, 7)).Select Selection.Copy sh2.Select FinalRow = Range("A65536").End(xlUp).Row NextRow = Range("A65536").End(xlUp).Row + 1 Range("A" & NextRow).Select ActiveSheet.Paste End If os2 = os2 + i2 If os2 < UBound(sh2Data, 1) Then With sh2 sh2DataA = .Range(.Cells(i2 + os2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 1) sh2Data = .Range(.Cells(i2 + os2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4) End With DoSearch = True Else DoSearch = False End If Else shM.Activate shM.Range(Cells(iM, 1), Cells(iM, 7)).Select Selection.Copy sh2.Select FinalRow = Range("A65536").End(xlUp).Row NextRow = Range("A65536").End(xlUp).Row + 1 Range("A" & NextRow).Select ActiveSheet.Paste DoSearch = False End If Loop Until Not DoSearch Next End Sub 

消息框仅用于validation代码是否正常工作 – 并不是必需的组件。 再次感谢您的build议。

Answer 1

假设您从未在主列表中获得两行完全相同的东西，则可以使用内置的Excelfunction删除重复项（至less在2010年的“数据”选项卡上）。 如果你有x个重复的行，所有相同的，它们的x-1被删除。 因此，您可以复制整个其他表，将其粘贴到主列表下，然后在主列表上运行删除重复项。 所有你需要知道的是删除重复的VBA。

  ActiveSheet.Range("$A$40:$D$43").RemoveDuplicates Columns:=Array(1, 3, 4), Header:=xlNo 

根据需要调整

Answer 2

谢谢大家的帮助，我find了一个解决scheme，但它不能在Excel 2003中工作。如果有人知道他们的头顶为什么这将是伟大的其他我想我弄明白了。 这是代码。

[HTML] Public Sub NewEntWhole（）Dim LoM As ListObject，Lo2 As ListObject Dim TblMData As Variant Dim iM As Long Dim dDate As Date Dim strDate As String Dim lDate As Long Dim rng As Range Dim ct As Variant Dim shM As Worksheet Dim sh2作为工作表昏暗hdM整数

 hdM = 0 'rows above table M Set shM = Sheets(1) Set sh2 = Sheets(2) Set loM = Sheets(1).ListObjects(1) Set lo2 = Sheets(2).ListObjects(1) With loM TblMData = .DataBodyRange End With For iM = 2 To UBound(TblMData, 1) + 1 sh2.Activate With lo2 .Range.AutoFilter Field:=1, Criteria1:=loM.Range(iM, 1).Value .Range.AutoFilter Field:=2, Criteria1:=loM.Range(iM, 2).Value If IsDate(loM.Range(iM, 4)) Then sDate = loM.Range(iM, 4) dDate = DateSerial(Year(sDate), Month(sDate), Day(sDate)) lDate = dDate .Range.AutoFilter Field:=4, Criteria1:=">=" & lDate, Operator:=xlAnd, Criteria2:="<" & lDate + 1 Else .Range.AutoFilter Field:=4, Criteria1:=loM.Range(iM, 4).Value End If End With Set rng = lo2.AutoFilter.Range ct = rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 If ct = 0 And loM.Range(iM, 1).Value > 0 Then shM.Activate shM.Range(Cells((iM + hdM), 1), Cells((iM + hdM), 7)).Copy sh2.Activate FinalRow = Range("B65536").End(xlUp).Row NextRow = Range("B65536").End(xlUp).Row + 1 Range("A" & NextRow).Select ActiveSheet.Paste End If With lo2 .Range.AutoFilter Field:=1 .Range.AutoFilter Field:=2 .Range.AutoFilter Field:=4 End With Next shM.Activate 

End Sub [/ HTML]