Sheet1表格删除某一列存在的重复项，并删除重复项整行，并将重复项保存在Sheet2中。

Sub 删除重复行()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim duplicate As Boolean
    
    ' 设置Sheet1和Sheet2
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' 获取Sheet1中D列最后一行
    lastRow = ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row
    
    ' 初始化标记变量
    duplicate = True
    
    ' 持续处理，直到D列不存在重复项
    Do While duplicate
        duplicate = False
        
        ' 从最后一行开始逐行比较
        For i = lastRow To 2 Step -1
            ' 检查当前行是否与之前的行存在重复
            For j = i - 1 To 1 Step -1
                If ws1.Cells(i, "D").Value = ws1.Cells(j, "D").Value Then
                    ' 若存在重复，将当前行复制到Sheet2中
                    ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1)
                    ' 删除重复行
                    ws1.Rows(i).Delete
                    ' 更新标记变量
                    duplicate = True
                    Exit For
                End If
            Next j
        Next i
        
        ' 更新D列最后一行
        lastRow = ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row
    Loop
    
End Sub