CODEWITHSUNDEEP
excel
Nytro
Nytro

Reputation: 143

(VBA) Delete duplicate cells in same region

I have a problem such that I cannot get to delete the duplicates within the same section (same name on Column B). It should scan each section and keep just the 1st unique value from each section.

The problem is that it analyzes if 2 consecutive rows have the same name (which indicates the section), and based on that deletes duplicates. It does not analyze each section comparing for example 1st row with last row, but 1 by 1, which is wrong, because the penultimate or the last row of each section might have a duplicate based on the 1st row.

Upvotes: 0

Views: 64

Answers (2)

Vincent
Vincent

Reputation: 510

I'm sure you can find better and more optimised code out here, this one does the job:

Sub DeleteDuplicates
    Dim ColBrand As Integer, ColMil As Integer, ColColor as Integer
    Dim RowSectionStart as Integer, RowCurrent as Integer
    Dim ws As Worksheet

    Set ws = Workbooks("Classeur1").Sheets("Feuil1")

    ColBrand = 2
    ColMil = 3
    ColColor = 4
    RowCurrent = 2

    Do While ws.Cells(RowCurrent, ColBrand).Value <> ""
        ' Section change if needed
        If RowCurrent = 1 Then
            RowSectionStart = RowCurrent
        ElseIf ws.Cells(RowCurrent, ColBrand) <> ws.Cells(RowCurrent - 1, ColBrand) Then
            RowSectionStart = RowCurrent
        End If

        If RowSectionStart <> RowCurrent Then
            ' Delete duplicate in Mil column
            If Not Range(ws.Cells(RowSectionStart, ColMil), ws.Cells(RowCurrent - 1, ColMil)).Find(ws.Cells(RowCurrent, ColMil).Value) Is Nothing Then
                ws.Cells(RowCurrent, ColMil).ClearContents
            End If

            ' Delete duplicate in Color column
            If Not Range(ws.Cells(RowSectionStart, ColColor), ws.Cells(RowCurrent - 1, ColColor)).Find(ws.Cells(RowCurrent, ColColor).Value) Is Nothing Then
                ws.Cells(RowCurrent, ColColor).ClearContents
            End If
        End If
        RowCurrent = RowCurrent + 1
    Loop

    Set ws = Nothing

End Sub

This image shows you the effect of the code. The content in yellow cells are deleted, as they are already mentionned upper in the same 'section'.

enter image description here

Upvotes: 1

Hronic
Hronic

Reputation: 155


In order to solve this, I would create 2x dictionaries:
1st dictionary (1): Key: Name + Mil, Value: does not actually matter
2nd dictionary (2): Key: Name + Color, Value: does not actually matter

You loop starting from Top/Bottom to Bottom/Top.
For each row you check if combination of column B & C exists in dictionary (1), if so-> delete values from cell (in column B), if does not exist -> add new combination to dictionary.

The same for combination of B & D (dictionary 2).

It should solve the issue.

Note:
For optimization purposes, put columns into arrays (arrColB = shtWorking.Range("B:B")).

Here is transparent explanation of dictionaries:
https://excelmacromastery.com/vba-dictionary/

Provided that I understood the logic of duplicates, it would look like this: 

Sub StackOverflow()

Dim lngI As Long
Dim lngLastRow As Long
Dim dicNameMil As Object
Dim dicNameColor As Object
Dim shtWorking As Object
Dim arrColB As Variant
Dim arrColC As Variant
Dim arrColD As Variant
Dim strKey As String

'set objects
Set shtWorking = Sheets(1)
Set dicNameMil = CreateObject("Scripting.Dictionary")
Set dicNameColor = CreateObject("Scripting.Dictionary")

lngLastRow = shtWorking.Cells(shtWorking.Rows.Count, 1).End(-4162).Row 'find last row with data/base on column A
arrColB = shtWorking.Range("B:B")
arrColC = shtWorking.Range("C:C")
arrColD = shtWorking.Range("D:D")

For lngI = 2 To lngLastRow Step 1
    'validate column C
    strKey = arrColB(lngI, 1) & arrColC(lngI, 1)
    If dicNameMil.exists(strKey) Then
       shtWorking.Range("C" & lngI).Value = ""
    Else
        dicNameMil.Add strKey, "New combination of Name and Mil"
    End If
    'Validate column D
    strKey = arrColB(lngI, 1) & arrColD(lngI, 1)
    If dicNameMil.exists(strKey) Then
       shtWorking.Range("D" & lngI).Value = ""
    Else
        dicNameMil.Add strKey, "New combination of Name and Color"
    End If
Next lngI

'set objects to nothing
Set shtWorking = Nothing
Set dicNameMil = Nothing
Set dicNameColor = Nothing

End Sub

Upvotes: 0

Related Questions