将数据复制到没有重复的另一张纸

Question

我有一个主表（Sheet1），该表具有产品数据库（名称，参考，到期日期，状态，...）。

我的目标是根据一定条件（产品的状态）将数据复制到两张纸（Sheet3＆amp; Sheet4）。

每次打开Excel文件时，我的代码都会运行（因为状态可以根据到期日期更改）。
第一次打开文件时，我按计划获得复制数据。保存文件，然后关闭。
当我打开文件并在另一个时间执行代码时，复制相同的数据。因此，我得到了重复。

我添加了一些内容以删除重复项，但是代码运行缓慢。

Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range
Dim DuplicateValues As Range
Dim DuplicateValues2 As Range

Set StatusCol = Sheet1.Range("G2:G999999")

For Each Status In StatusCol
    
    If Sheet3.Range("A2") = "" Then
        Set PasteCell = Sheet3.Range("A2")
    Else
        Set PasteCell = Sheet3.Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status = "about to expire" Then Status.EntireRow.Copy PasteCell
    
    If Sheet4.Range("A2") = "" Then
        Set PasteCell = Sheet4.Range("A2")
    Else
        Set PasteCell = Sheet4.Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status = "expired" Then Status.EntireRow.Copy PasteCell
    
Next Status

Set DuplicateValues = Sheet3.Range("A1:XFD1048576")
Set DuplicateValues2 = Sheet4.Range("A1:XFD1048576")

DuplicateValues.removeduplicates Columns:=Array(1), Header:=xlYes
DuplicateValues2.removeduplicates Columns:=Array(1), Header:=xlYes

End Sub

我试图添加一个条件，该条件验证数据是否已经存在于要制作副本的表中；因此，仅复制新数据。

Dim StatusCol As Range
Dim Status As Range
Dim Code As Range
Dim CodeCol As Range
Dim Code2 As Range
Dim CodeCol2 As Range
Dim PasteCell As Range
Dim DuplicateValues As Range
Dim DuplicateValues2 As Range

Set StatusCol = Sheet1.Range("G2:G999999")
Set CodeCol = Sheet3.Range("D2:D999999")
Set CodeCol2 = Sheet4.Range("D2:D999999")

For Each Status In StatusCol
    
    If Sheet3.Range("A2") = "" Then
        Set PasteCell = Sheet3.Range("A2")
    Else
        Set PasteCell = Sheet3.Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status = "about to expire" Then
        
        With CodeCol
            Set Code = .Find(What:=CodeCol.Value, _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
            If Not Code Is Nothing Then
            Else
                Status.EntireRow.Copy PasteCell
            End If
        End With
    End If
    
    If Sheet4.Range("A2") = "" Then
        Set PasteCell = Sheet4.Range("A2")
    Else
        Set PasteCell = Sheet4.Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status = "expired" Then
        
        With CodeCol2
            Set Code2 = .Find(What:=CodeCol2.Value, _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
            If Not Code2 Is Nothing Then
            Else
                Status.EntireRow.Copy PasteCell
            End If
        End With
    End If
    
Next Status

End Sub

我没有收到任何错误，但是副本不会发生。

Answer 1

假设查找或后续如果语句正在引起问题，我会与以下相似的情况有所帮助：

dim destinationSheet as worksheet
select case Status.Value
    Case "about to expire"
        set destinationSheet = Sheet2
    Case ""
        set destinationSheet = Sheet3
end select
dim uniqueID as string
uniqueID = Status.Offset(,-3).Value 'Arbitrary -3 offset to the cell in the row with the ID to be found
dim uniqueIDCheck as range
set uniqueIDCheck = destinationSheet.Find(uniqueID)
if uniqueIDCheck is nothing then
    dim destinationLastRow as long
    destinationLastRow = destinationSheet.Cells(destinationSheet.Rows.Count,1).End(xlup).Row
    destinationSheet.Rows(destinationLastRow+1).Value = Status.EntireRow.Value
end if