Slightly Modify VBA Code that deletes Dups

[gheyman]

i need to modify this code because the data has changed with respect to column location.
previously the pertinent data was in B & C

It is now in C & E

I think changing it is straight forward except for this part
"lngLastRow = Range("B:C")"

Any help is appreciated!

Sub Delete_Duplicates()
'Author: G Heyman 190217
'Delete all duplicate rows so part number is only listed once for each Top level Assy

    Dim objMyUniqueData As Object
    Dim strMyKey As String
    Dim rngDelRange As Range
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    
    Application.ScreenUpdating = False

    lngLastRow = Range("B:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")

    For lngMyRow = 1 To lngLastRow
        If Len(Range("B" & lngMyRow)) > 0 And Len(Range("C" & lngMyRow)) > 0 Then
            strMyKey = Range("B" & lngMyRow) & Range("C" & lngMyRow)
            If objMyUniqueData.Exists(CStr(strMyKey)) = False Then
                objMyUniqueData.Add strMyKey, CStr(strMyKey)
            Else
                If rngDelRange Is Nothing Then
                    Set rngDelRange = Rows(lngMyRow)
                Else
                    Set rngDelRange = Union(rngDelRange, Rows(lngMyRow))
                End If
            End If
        End If
    Next lngMyRow
    
    Set objMyUniqueData = Nothing
    
'    If Not rngDelRange Is Nothing Then
'        rngDelRange.EntireRow.Delete
 '       MsgBox "Rows with Duplicate Part ID and End Part ID have now been deleted.", vbInformation
 '   Else
 '       MsgBox "There were no duplicated records found for Part ID and End Part ID. Nothing was deleted.", vbExclamation
 '   End If
    
    Application.ScreenUpdating = True
    
End Sub

 

[DanteAmor]

Try this

Sub Delete_Duplicates()
  Dim objMyUniqueData As Object, strMyKey As String, rngDelRange As Range
  Dim lngLastRow As Long, lngMyRow As Long
  Application.ScreenUpdating = False
  lngLastRow = Range("[COLOR=#0000ff]C:E[/COLOR]").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Set rngDelRange = Rows(lngLastRow + 1)
  Set objMyUniqueData = CreateObject("Scripting.Dictionary")
  For lngMyRow = 1 To lngLastRow
    If Len(Range("[COLOR=#0000ff]C[/COLOR]" & lngMyRow)) > 0 And Len(Range("[COLOR=#0000ff]E[/COLOR]" & lngMyRow)) > 0 Then
      strMyKey = Range("[COLOR=#0000ff]C[/COLOR]" & lngMyRow) & Range("[COLOR=#0000ff]E[/COLOR]" & lngMyRow)
      If objMyUniqueData.Exists(CStr(strMyKey)) = False Then
        objMyUniqueData.Add strMyKey, CStr(strMyKey)
      Else
        Set rngDelRange = Union(rngDelRange, Rows(lngMyRow))
      End If
    End If
  Next lngMyRow
  Set objMyUniqueData = Nothing
  rngDelRange.EntireRow.Delete
  MsgBox "End"
  Application.ScreenUpdating = True
End Sub

 

[gheyman]

That worked! Muchas gracias amigo.

 

[DanteAmor]

Con mucho gusto!. Thanks for the feedback.