刪除列中的重復值，只留下行數較高的值

Question

有一個工作表scr ，其中列P具有以下視圖：

P1=100
P2=100
P3=100
P4=100
P4=101
P5=101
P6=102
P7=102
P8=102

，這意味着存在唯一值塊。 我只需要保留上限值（此處 - P1 、 P4 、 P6 ）。 其他重復的值應該被刪除。 因此，我編寫了下面的代碼，但它不起作用並且沒有錯誤。

Sub Test()

Dim wb1 As Workbook                                                 
Set wb1 = ActiveWorkbook                                            
Set src = wb1.Sheets("Modules_List")                                

Application.ScreenUpdating = False                                  
Application.Calculation = xlCalculationManual
Dim i As Long
Dim k As Integer
With src
    For i = 1 To 100
        For k = 1 To 100
            If .Cells(i, "P").Value = .Cells(i + k, "P").Value Then .Cells(i + k, "P").Value = ""
        Next k
    Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Answer 1

這是您最后三個問題的完整代碼。

Sub Copy_Data_by_Criteria()

    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim src As Worksheet
    Dim Dst As Worksheet
    Dim src2 As Worksheet


    Set wb1 = ActiveWorkbook
    Set wb2 = Workbooks.Open(Filename:="C:\Test.xlsx")
    Set src = wb1.Sheets("Sheet1")
    Set Dst = wb2.Sheets("Sheet1")
    Set src2 = wb1.Sheets("Base 1")

    Dim LastRow As Long
    Dim r As Range
    Dim CopyRange As Range
    Dim Crit As Range
    Dim strValue As Variant
    LastRow = src.Cells(src.Rows.Count, "P").End(xlUp).Row

    For Each Crit In src2.Range("G10:G" & 30)
        If Crit <> "" Then
            For Each r In src.Range("P6:P" & LastRow)

                If r <> 0 Then strValue = r

                If strValue = Crit Then
                    If CopyRange Is Nothing Then
                            Set CopyRange = r.EntireRow
                    Else
                            Set CopyRange = Union(CopyRange, r.EntireRow)
                    End If
                End If
            Next r
        End If
    Next Crit
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Dst.Range("A1")
    End If

End Sub

至於為什么你當前的代碼沒有做你想要的，因為你循環添加了你需要循環刪除它們的值：

Sub Test()

Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
Set src = wb1.Sheets("Modules_List")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim k As Integer
With src
    For i = 100 To 1
        If .Cells(i, "P").Value = .Cells(i - 1, "P").Value Then .Cells(i, "P").Value = ""
    Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub