将数据复制到另一个工作表，不重复

Question

我有一个主工作表(Sheet1)，其中包含产品数据库(名称，参考，有效期，状态，…)。

我的目标是将数据复制到两个工作表(Sheet3 &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

假设Find或随后的If语句导致了问题，我希望下面类似的内容可能会有所帮助:

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