Solved: Delete duplicate data in a Column

[parscon]

I Have a Problem with this VBA code , i want to delete just duplicate data on Column B , just Column B . but this code delete row also .
that beter i write i want to remove duplicate just i 1 Column and also remove the blank cell on that column alo .

Please help me .

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

[shrivallabha]

This part deletes entire row:
[VBA]Range("B" & x).EntireRow.Delete[/VBA]
so change it to:
[VBA]Range("B" & x).Delete[/VBA]

[parscon]

Thank you for your help , it is ok but there is 1 problem and 1 question .

I have A - B - C - D column when use your code all duplicate data on column B romoved but the latest data of column C add to end of column B . where is the probme?

if i want to use this code for A- B - C - D column that mean remove duplicate data of each column , please help me how can do it .

[shrivallabha]

This should settle the first part:
[VBA]Range("B" & x").Delete Shift:=xlUp[/VBA]

I am little unclear about your requirement:

Do you mean check for duplicates in each column separately and deleting them?
e.g. Duplicate found in B2 so delete B2 only.

Or When duplicate is found in column B then delete four cells together?
e.g. Duplicate found in B2 so delete A22?

[parscon]

Yes , I want check for duplicates in each column separately and deleting them.

Thank you very much for your big help .

[shrivallabha]

Then this should work:
[VBA]Dim i As Integer
Dim x As Long
Dim LastRow As Long
Application.ScreenUpdating = False
For i = 1 To 4
LastRow = Cells(65536, i).End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.CountIf(Range(Cells(1, i), Cells(x, i)), Cells(x, i).Value) > 1 Then
Cells(x, i).Delete Shift:=xlUp
End If
Next x
Next i
Application.ScreenUpdating = True[/VBA]

[parscon]

You are the best mam . you help me so much and thank you for your help .

[parscon]

just my latest question , could please add a code to remove blank celll also ?

[shrivallabha]

OK. I am assuming that there are no cells with formulas that give blanks.
[vba]Dim i As Integer
Dim x As Long
Dim LastRow As Long
For i = 1 To 4
LastRow = Cells(65536, i).End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.CountIf(Range(Cells(1, i), Cells(x, i)), Cells(x, i).Value) > 1 Then
Cells(x, i).Delete Shift:=xlUp
End If
Next x
On Error Resume Next
Range(Cells(1, i), Cells(LastRow, i)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0
Next i[/vba]

[parscon]

Thank you So much For your Helo Man .
Have a Good Day .

[parscon]

Fr this one please add the code to remove blank cell after delete,

Pleaseeeeeeeeee

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

[parscon]

it is done .

Thank you very much shrivallabha

 

Dim x               As Long
Dim LastRow         As Long
    LastRow = Range("B65536").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("B1:B" & x), Range("B" & x).Text) > 1 Then
            Range("B" & x).Delete Shift:=xlUp
        End If
    Next x  
    On Error Resume Next 
    Range(Cells(1, "B"), Cells(LastRow, "B")).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 
    On Error Goto 0 
Next B