简体   繁体   中英

Remove duplicated values in column, leaving only those which are higher in terms of rows

There is a sheet scr where column P has the following view:

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

, meaning there are blocks of unique values. I need to leave only the upper value (here - P1 , P4 , P6 ). The other duplicated values should be erased. Therefore, I made the code below, but it does not work and gives no error.

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

Here is your entire code over you last three questions.

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

As to why your current code did not do what you wanted, Since you looped down to add the values you need to loop up to remove them:

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

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM