Code Fix to Delete Duplicates

[Alex O]

I'm in the process of putting the below code together to essentially create a new text file>delete duplicates>attach to email and send to client. Everything seems to functioning correctly except the DeleteDups procedure is not deleting the duplicates! It's strange because the code is executing and seems to be performing as intended, except it doesn't delete anything!

Any thoughts and/or suggestions would be appreciated.

Sub CopytoNewWorkbook()
    Workbooks.Add
    ThisWorkbook.Worksheets(2).Range("A6:P200").Copy
    Range("A6").PasteSpecial 
    Paste:=xlPasteValues
    Range("A6").PasteSpecial 
    Paste:=xlPasteFormats
    Columns.AutoFit
End Sub

Sub DeleteDups()
    Dim x As Long
    Dim LastRow         As Long
    LastRow = Range("B200").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("B7:B" & x), Range("B"& x).Text) > 1 Then
            Range("B" & x).EntireRow.Delete
        End If
    Next x
End Sub

Sub MailSheet()
    Dim shtName As String
    shtName = ActiveSheet.Name
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs "List" & Format(Date, "mm-dd-yyyy") & ".xls"
    Application.DisplayAlerts = False
    Application.Dialogs(xlDialogSendMail).Show
    With ActiveWorkbook
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close 
        False
    End With
    Application.DisplayAlerts = True
End Sub

[SamT]

The only problem I can see with your code without running it is that "For x = LastRow To 1" should read "For x = LastRow To 7."

Anyway, try this version.

Option Explicit

Sub DeleteDups()
    Dim c As Long
    Dim MyRange As Range
    Set MyRange = Range("B7:B" & CStr(Cells(Rows.Count, 2).End(xlUp).Row))
    For c = MyRange.Cells.Count To 1 Step -1
    If Application.WorksheetFunction.CountIf(MyRange, _
        MyRange.Cells(c).Value) > 1 Then _
        MyRange.Cells(c).EntireRow.Delete
    Next c
End Sub

[Alex O]

Worked perfectly....thanks!

Alex