刪除重複的值，只留下那些更高的行

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(x1Up).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