行正在被复制并从一个工作簿粘贴到另一个时复制行

我有一个代码，允许我根据我想复制的国家进行过滤，并将其从一个工作簿粘贴到另一个工作簿。 然而，我面对的问题是当我运行的代码不止一次，find重复的行。 我不知道如何对代码进行改进，以允许代码防止重复行发生。 以下是我目前的代码。 它从外部工作簿复制时给了行的重复。 我想search的条件是“新加坡”，它在外部工作手册“主动主项目”中出现了不止一次。 因此，下面的代码将帮助find所有包含“新加坡”的行，并将其粘贴到另一个名为“新即将开展的项目”的工作簿中。 但是，当代码运行多次时，它将复制先前已经被复制的行。 外部工作簿将每月添加新行，因此下面的代码将允许search“新加坡”并将行粘贴到另一个工作簿中。 但是，它也复制了以前被复制的行。 因此，我有点卡在当前的代码。

Sub UpdateNewUpcomingProj() Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet Dim copyFrom As Range Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel Dim strSearch As String Set wb1 = Application.Workbooks.Open("U:\Active Master Project.xlsm") Set ws1 = wb1.Worksheets("New Upcoming Projects") strSearch = "Singapore" With ws1 '~~> Remove any filters .AutoFilterMode = False '~~> I am assuming that the names are in Col A '~~> if not then change A below to whatever column letter lRow = .Range("A" & .Rows.Count).End(xlUp).Row With .Range("A1:A" & lRow) .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*" Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow End With .AutoFilterMode = False End With '~~> Destination File Set wb2 = ThisWorkbook Set ws2 = wb2.Worksheets("New Upcoming Projects") With ws2 If Application.WorksheetFunction.CountA(.Cells) <> 0 Then lRow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else lRow = 2 End If copyFrom.Copy .Rows(lRow) End With End Sub 

下面是一个名为Active Master Project的外部工作簿，用来指向search“新加坡”

将上面的代码粘贴到“新build项目”工作簿中。 看起来像这样： 但是，当我再次运行代码，上面的信息将被复制。 任何帮助，将不胜感激。 谢谢 ：）

Answer 1

当您重新运行代码时，它将被复制，因为您不检查目标工作表中的重复。 解决这个问题的一种方法是在复制之前检查重复项，例如在projectId字段中。

但是一个简单而快速的修复就是在复制操作之后删除重复的行，如下所示：

copyFrom.Copy .Rows(lRow)后copyFrom.Copy .Rows(lRow)

 .Rows.RemoveDuplicates Array(1, 2, 3, 4), xlNo 

这将删除基于所有列A，B，C和D的重复行。您可能希望基于projectId进行检查，因此该数组只能是Array（2），或者在多列上，只需将其索引放在arrays。 当然，这不是一个美观的解决scheme，但避免你从源和目的地（两个嵌套循环）逐行检查重复。

Answer 2

假设你只想检查你的searchstring是否已经存在，那么你可以使用另一个Findtesting，如果没有发现，粘贴结果，就像这样…

 Dim duplicateRng As Range ' // ... // Set duplicateRng = .Cells.Find(What:=strSearch, _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=True) If duplicateRng Is Nothing Then copyFrom.Copy .Rows(lRow) End If 

但是，如果你想检查每行中的每个单元格与粘贴行中的每个单元格匹配，那么你真的需要运行一个循环，并testing所有的值。