Excel macro to remove duplicates within a group

[Learner99]

Hi,
I'm struggling to write a multidimensional array.
Could you please help?

Here is what I’m trying to do...

With alot of help I was able to write a OBject dictionary in a loop that removes dupes.
During this build I did not take into account that I needed to restart the loop whenever the cell in column L is not the same as the next cell down.

Here is an example of my input Data:

Column L Column P
Row 1 9 10,500
Row 2 9 10,500
Row 3 9 6,000
Row 4 8 --------
Row 5 8 6,000
Row 6 8 6,000
Row 7 8 5,250
Row 8 8 --------
Row 9 7 6,000
Row 10 7 10,500

I would like the output to look like this:

Column L Column P
Row 1 9 10,500
Row 2 9 6,000
Row 3 8 --------
Row 4 8 6,000
Row 5 8 5,250
Row 6 8 --------
Row 7 7 6,000
Row 8 7 10,500

Rows 2 and 6 were deleted because they were dupes in the same group in column L


Thank you in advance for your help.

Sub RemoveDupes()
'
'
Dim ObjDic  As Object
Dim RowInfo() As Variant
Dim counter As Long
Dim r As Range: Dim F   As Range
Dim n As Long
Dim LastRow  As Long
Dim WkRg  As Range
    
Dim x As Range
Dim z As Long
    
    If ActiveSheet.Select <> "Sheet1" Then
     Sheets("Finishing Schedule Report").Select    ' selects the sheet
    End If
    
    Range("L1").Select         ' select a column
    
    Set ObjDic = CreateObject("Scripting.Dictionary")
    With Sheets("Finishing Schedule Report")
        LastRow = .Range("P" & Rows.Count).End(xlUp).Row
        Set WkRg = .Cells(LastRow + 1, "P")
        Set r = .Range("P1:P" & LastRow)      ' This is where you set the column to sort on
        

        Set x = .Range("L1:" & Selection.Address)   ' number location   '  <---- does not work 
        ReDim RowInfo(1 To LastRow)                    '  <---- does not work 
        
        
      For z = 1 To x.Rows.Count                        '  <---- does not work 
       If x.Cells(z, 1) <> x.Cells(z + 1, 1) Then            '  <---- does not work 
 
         For Each F In r
              If (F.Value = "--------") Then
                n = n + 1: RowInfo(n) = F.Value
              Else
                If Not (ObjDic.exists(F.Value)) Then
                    n = n + 1: RowInfo(n) = F.Value: ObjDic(F.Value) = Empty
                Else
                Set WkRg = Union(WkRg, F)
                End If
              End If
          Next F
        
        End If                                '  <---- does not work 
       Next z                                '  <---- does not work 
        
        
        '========================================================================
    WkRg.EntireRow.Delete
    End With
End Sub

 

[Useful]

Hi, try this

Sub Remove_Dupes()
r = Cells(Rows.Count, 12).End(xlUp).Row
For i = r To 2 Step -1
Set Rng = Cells(i, 16).Offset(-1).Resize(2)
If Application.WorksheetFunction.CountIf(Rng, Cells(i, 16)) > 1 Or Cells(i, 12) = "" Then
Cells(i, 12).EntireRow.Delete Shift:=xlUp
End If
Next i
End Sub

 

[Learner99]

Hi, try this

Sub Remove_Dupes()
r = Cells(Rows.Count, 12).End(xlUp).Row
For i = r To 2 Step -1
Set Rng = Cells(i, 16).Offset(-1).Resize(2)
If Application.WorksheetFunction.CountIf(Rng, Cells(i, 16)) > 1 Or Cells(i, 12) = "" Then
Cells(i, 12).EntireRow.Delete Shift:=xlUp
End If
Next i
End Sub

Sorry no that doesn't do what I'm looking for.
The code I wrote works except for the lines I marked out. Can you help me fix them?
Thank you again for your time and effort.

 

[Useful]

Hi, use

Debug.Print

to see how works each line of your code. For example

debug.print x.Rows.Count

print result is 1. Instead of this if you want to show last row number then it already exist in your decleration. And also unnecessary

If x.Cells(z, 1) <> x.Cells(z + 1, 1) Then

line checks "Column L" which contains row numbers (not amounts). Your code has extra scripts and it removes only duplicates. Suggested code gives the result as you showed at the first post.

 

[Learner99]

Thank you for the debug info. Also I dont think we are on the same page with column L. Column L is only being used to check the cells current value against the next cell down in the same column. If its the same, the loop should continue. If it is different the loop inside that loop should start over checking starting at the next cell down.

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG07Jul34
[COLOR="Navy"]Dim[/COLOR] Rng             [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn              [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic             [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] oTxt            [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRng            [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("L1"), Range("L" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn <> "" And Dn.Offset(, 4) <> "" [COLOR="Navy"]Then[/COLOR]
        oTxt = Dn & Dn.Offset(, 4)
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(oTxt) [COLOR="Navy"]Then[/COLOR]
            Dic.Add oTxt, Nothing
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Dn
             [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Learner99]

That is Perfect Mick! You nailed it!
Thanks so much.

 

[MickG]

You're welcome