Removing Duplicates

[Cruiser69]

Hi all.
Is there anyone that can please help removing duplicates.
I have searched, but can't find an answer.
We have stock which is scanned. When we export the excel workbook it comes through as in the example below.
Sometimes it duplicates the numbers in column A.
I can't use the delete duplicates down vba, as the description for number 5 is below what would be deleted.
Row 3 would be deleted as well as row 8.
The cells in column B which are empty are fine, as we will fill in the descriptions as we go.
Is there a vba or formula which would accomplish this. Either to remove the row, or remove the duplicate number.

Thanks for looking,

Graham

 

[kevin9999]

Try the following on a copy of your worksheet.

Option Explicit
Sub Cruiser69()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<~~ Change to actual sheet name
    Dim LRow As Long, LCol As Long, i As Long
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    Dim r As Range
    Set r = ws.Range("A2:A" & LRow).Resize(, 2)
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To 1)
    For i = 1 To UBound(a, 1)
        If WorksheetFunction.CountIf(r.Columns(1), a(i, 1)) > 1 And a(i, 2) = "" Then b(i, 1) = 1
    Next i
    ws.Cells(2, LCol).Resize(UBound(b, 1)).Value = b
    
    i = WorksheetFunction.Sum(ws.Columns(LCol))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
Application.ScreenUpdating = True
End Sub

 

[Cruiser69]

Try the following on a copy of your worksheet.

Option Explicit
Sub Cruiser69()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<~~ Change to actual sheet name
    Dim LRow As Long, LCol As Long, i As Long
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
   
    Dim r As Range
    Set r = ws.Range("A2:A" & LRow).Resize(, 2)
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To 1)
    For i = 1 To UBound(a, 1)
        If WorksheetFunction.CountIf(r.Columns(1), a(i, 1)) > 1 And a(i, 2) = "" Then b(i, 1) = 1
    Next i
    ws.Cells(2, LCol).Resize(UBound(b, 1)).Value = b
   
    i = WorksheetFunction.Sum(ws.Columns(LCol))
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
Application.ScreenUpdating = True
End Sub

Hi Kevin.

This is perfect.

Thanks for your help.

Regards,

Graham

 

[kevin9999]

Hi Kevin.

This is perfect.

Thanks for your help.

Regards,

Graham

Happy to help Graham, and thanks for the feedback