Question

我有一个代码，允许我根据我要复制的国家进行过滤，并将其从一个工作簿粘贴到另一个工作簿。然而，我面临的一个问题是，当我多次运行代码时，会找到重复的行。我不知道如何改进代码以允许代码防止重复行发生。以下是我目前的代码。从外部工作簿复制时，它给出了重复的行。我想搜索的条件是＆＃34;新加坡＆＃34;它在外部工作簿中不止一次出现，名为＆＃34; Active master project＆＃34;。因此，下面的代码将有助于找到所有包含＆＃34;新加坡＆＃34;并将其粘贴到另一个工作簿中，该工作簿有一个名为＆＃34; New Upcoming Projects＆＃34;的工作表。但是，当代码多次运行时，它将复制先前已复制的行。外部工作簿将每月添加新行，因此下面的代码将允许搜索＆＃34;新加坡＆＃34;并将行复制粘贴到另一个工作簿中。但是，它还会复制先前已复制的行。因此，我对当前的代码感到有点困惑。

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的外部工作簿，用于指代搜索＆＃34; Singapore＆＃34;

将上面的代码粘贴到＆＃34; New Upcoming Project＆＃34;工作簿。看起来像这样：但是，当我再次运行代码时，上述信息将被复制。任何帮助，将不胜感激。谢谢:)）

Answer 1

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

但是一个简单而快速的解决方法是在复制操作后删除重复的行，如下所示：

在copyFrom.Copy .Rows(lRow)

之后

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

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

Answer 2

假设您只想检查您的搜索字符串是否已存在，那么您可以使用另一个Find测试，如果没有找到，则粘贴结果，如此...

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

但是，如果要检查每行中的每个单元格是否与粘贴行中的每个单元格匹配，那么您确实需要运行循环并测试所有值。

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

2 个答案: