复制唯一值（2列）

Option Explicit

Sub CopyUniqueValues()

    ' Write the values from the source to an array.

    Dim sws As Worksheet: Set sws = Workbooks("Bookcopy.xlsm").Worksheets("copy")
    
    Dim Data(), srCount As Long, cCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1
        If srCount = 0 Then Exit Sub ' no data
        cCount = .Columns.Count
        Data = .Resize(srCount).Offset(1).Value
    End With
    
    ' Write the unique values from the array to the 'keys' of a dictionary
    ' and their rows of the values' first occurrences to the 'items'.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sr As Long, sString As String
    
    For sr = 1 To srCount
        sString = Data(sr, 4) & "@" & Int(Data(sr, 3))
        If Not dict.Exists(sString) Then dict(sString) = sr
    Next sr
    
    ' Using the rows from the 'items' of the dictionary, write the unique rows
    ' to the top of the array.
    
    Dim sKey, tr As Long, c As Long
    
    For Each sKey In dict.Keys
        sr = dict(sKey)
        tr = tr + 1
        For c = 1 To cCount
            Data(tr, c) = Data(sr, c)
        Next c
    Next sKey
    
    ' Reference the target range.
    Dim tws As Worksheet: Set tws = Workbooks("Bookpaste.xlsm").Worksheets("paste")
    Dim tCell As Range: Set tCell = tws.Cells(tws.Rows.Count, "A").End(xlUp).Offset(1)
    Dim trg As Range: Set trg = tCell.Resize(tr, cCount)
    
    ' Write the top rows from the array to the target range.
    trg.Value = Data
    ' Clear below.
    trg.Resize(tws.Rows.Count - trg.Row - tr + 1).Offset(tr).ClearContents
    
    ' Inform.
    MsgBox "Unique values copied.", vbInformation

End Sub

您可以使用内置AutoFilter()和RemoveDuplicates()功能的Excel

Sub ConditionalRowCopy()

    With Workbooks("Bookcopy.xlsm").Worksheets("copy")
        With .Range("D1", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=3, Criteria1:=">06/01/2020"
                If Application.Subtotal(103, .Resize(, 1)) > 1 Then
                    .SpecialCells(xlCellTypeVisible).Copy Destination:= Workbooks("Bookpaste.xlsm").Worksheets("paste").Range("A1")
                        With  Workbooks("Bookpaste.xlsm").Worksheets("paste")
                            With .Range("D1", .Cells(.Rows.Count, 1).End(xlUp))
                                .RemoveDuplicates Columns:=Array(3, 4), Header:=xlNo
                            End With
                        End With
                End If
        End With
        .AutoFilterMode = False
    End With
    
End Sub