Remove Duplicates using VBA Code

[Tarek_CTG]

I have coded this in one of my workbooks:

With wsA
        dtD = .Range("D2")      ' Date cell
               
    End With


UBB = UBound(vRB, 1)
ReDim vRG(1 To 12, 1 To 1)


    For lRC = 2 To UBB
        If dtD - vRB(lRC, 3) > 0 And dtD - vRB(lRC, 7) = dtD And Len(Trim(vRB(lRC, 2))) And InStr(vRB(lRC, 2), "None") = 0 And InStr(vRB(lRC, 2), "NULL") = 0 And InStr(vRB(lRC, 2), "_COW") = 0 And InStr(vRB(lRC, 2), "D_") = 0 And InStr(vRB(lRC, 2), "D2_") = 0 And InStr(vRB(lRC, 2), "D3_") = 0 And InStr(vRB(lRC, 4), "ERC-3G-") = 0 And InStr(vRB(lRC, 4), "NSN-WCDMA") = 0 Then   ' time difference > 0 hrs
            
                UBG = UBound(vRG, 2) + 1
                ReDim Preserve vRG(1 To 12, 1 To UBG)
                ' copy the values from input to output array
                
                For lRB = 1 To 10
                    vRG(lRB + 1, UBG) = vRB(lRC, lRB)
                Next lRB
                                 
                ' put date in correct format
                    vRG(3, UBG) = Format(vRG(3, UBG), "DD/MM/YYY HH:MM")
                    
                    ' check if Region in All Site
                    For lRI = 3 To UBI
                        If Right(vRB(lRC, 2), 7) = vRI(lRI, 1) Then  ' same code
                            vRG(1, UBG) = vRI(lRI, 3)   ' copy region to first column of vRC
                            
                            Exit For
                        End If
                    Next lRI
                       
                  vRG(12, UBG) = dtD - vRB(lRC, 3)
                    'vRG(12, UBG) = Format(vRG(12, UBG), "HH:MM")
                  
            End If
       
    Next lRC 
    
    ' copy headings
    vRG(1, 1) = "Region"
 
    For lRB = 1 To 10
        vRG(lRB + 1, 1) = vRB(1, lRB)
    Next lRB
   
    With wsG.Range("C4")
        .CurrentRegion.ClearContents
        .Resize(UBound(vRG, 2), UBound(vRG, 1)).Value = Application.WorksheetFunction.Transpose(vRG)
    End With

Now, I want to remove duplicates rows according to the base of E column. When I run macro using this VBA code, an output is coming. In that output, in E column I have seen some duplicates are also coming. But I only need one data among the duplicates. For exmaple, in my E column I have found "CMCDG31" comes 3 times, but I only need once, rest 2 should be deleted.

But there is one more thing, I should count only 7 letters from Right when removing duplicates from E column. For example: If there is CMCDG31, D_CMCDG31, I_CMCDG31 then all of these should be count as duplicates, as If I use Right(Cell,7), then output of all of these three cells are same, that is CMCDG31. So, I have to discard 2 rows and keep 1.

I need the vba code for removing these duplicates with entire row.

Thanks in Advance.

 

[Tarek_CTG]

Is there anyone to help me ?

 

[RickXL]

Hi,

Just one point before I start, it can be counter-productive to add a follow-up post to your own initial post. This is because the default search looks for posts that have no answers. If you reply to your own post then it will disappear from the standard "xero replies" search.

Solution:

What you could do is create a second array the same size as the first. You then loop through all the entries and if the record is not a duplicate then you write it to the second array. This array is then used to create the output.

How to find the duplicates?

I tend to think of the Dictionary Object when I have "duplicate" issues to solve. You can add Keys and Items to a Dictionary and it has the advantages that if you know a key then the object is direct access and it also prevents duplicate keys from existing.

So the process would be:
1. Create a new output array.
2. Process each row in turn.
3a. If the key is not in the Dictionary then copy the record.
3b. Also, add the key to the Dictionary.
4. Finally, output the new array.

As your sample code is not complete it is difficult to say exactly how new lines should be added - even if I had the necessary data to test it. So here is an example that reads in an array from the worksheet then does the necessary processing:

Sub Test()

    Dim ws   As Worksheet
    Dim i    As Long
    Dim j    As Long
    Dim vRG  As Variant
    Dim vRG2 As Variant
    Dim dic  As Object
    Dim iOut As Long
    Dim Key  As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With ws
        vRG = .Range("A1:Z26").Value
        
        iOut = 1
        ReDim vRG2(1 To UBound(vRG, 1), UBound(vRG, 2))
        For i = 1 To UBound(vRG, 1)
            Key = Right(vRG(i, 5), 7)
            If Not dic.exists(Key) Then
                dic(Key) = vbNullString
                For j = 1 To UBound(vRG, 2)
                    vRG2(iOut, j) = vRG(i, j)
                Next
                iOut = iOut + 1
            End If
        Next
        .Range("I1").Resize(UBound(vRG2, 2), UBound(vRG2, 1)).Value = _
                Application.WorksheetFunction.Transpose(vRG2)
    End With

End Sub

 

[Tarek_CTG]

Not helpful