Help With Deleting Duplicate Rows Code

[Dazzawm]

I have the following code that when I select a column it deletes the entire row if the data is the same in rows in that column, What I need added to the code is that when it has to delete rows it colours in the remaining row. Thanks

Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim r As Long
Dim N As Long
Dim V As Variant
Dim rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(rng.Row, "#,##0")
N = 0
For r = rng.Rows.Count To 2 Step -1
If r Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(r, "#,##0")
End If
V = rng.Cells(r, 1).Value
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(rng.Columns(1), vbNullString) > 1 Then
rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(r).EntireRow.Delete
N = N + 1
End If
End If
Next r
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub

 

[Dazzawm]

I also would like to know if something else is possible. If the active column is B and the code decides a row(s) needs to be deleted can it take out whatever is column X of the rows that are being deleted and add the data to the remaining rows cell in column X?

 

[mirabeau]

This one is somewhat different from yours.

But maybe you can find use for it.

Sub delrows()
Dim d As Object, u(), nr&, xcol As Range
Dim c As Range, col, i&, k&, x
Set d = CreateObject("scripting.dictionary")
nr = Cells.Find("*", after:=Cells(1), searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
ReDim u(1 To nr, 1 To 1)
Set c = Cells(1, Columns.Count)
col = Selection.EntireColumn
Set xcol = Cells.Range("X:X")

For i = 1 To nr
    x = col(i, 1)
    If Not d.exists(x) Then
        d.Add x, i
    Else
        u(i, 1) = 1
        k = k + 1
        Cells.Rows(d(x)).Interior.Color = vbCyan
        xcol(d(x)) = xcol(d(x)) + xcol(i)
    End If
Next i

c.Resize(nr) = u
Cells.Resize(nr, Columns.Count).Sort c, 1
If k > 0 Then Cells.Resize(k, Columns.Count).Delete xlUp
End Sub

 

[Dazzawm]

That didnt work. I think it deleted the rows if the data was the same in column X. What I need it to do is delete duplicate rows in column A and add all the info that is in column X into the remaining rows column X. Thanks,

 

[mirabeau]

I have the following code that when I select a column it deletes the entire row if the data is the same in rows in that column, What I need added to the code is that when it has to delete rows it colours in the remaining row. Thanks

Your opening post didn't say that you wanted the code to work specifically for column A.

You said you wanted it to work for a column that you selected.

The code does just that. Presumably you had a cell in column X selected when you ran the code.

It's very easily modified to work for column A. Just change the one line

col = Selection.EntireColumn

to

col = Cells.Range("A:A")

or however you want to describe the column in which you want your duplicates analysed

 

[Dazzawm]

Your opening post didn't say that you wanted the code to work specifically for column A.

You said you wanted it to work for a column that you selected.

I did select column A and nothing happened, and your correct it is best if the code works for the column I select. Also I have noticed that when it adds the data from the deleted to X it jams it right next to the existing data rather adding a space. Thanks

 

[Dazzawm]

Ok, your original code works, just me being silly!. 2 further things please.

1. Like I said I need a space adding when it copies the data in the X column from the deleted rows.

2. Can I select further columns to do like it does with X? i.e add the data from column K or H or all 3 of them etc..?

Thanks.

 

[mirabeau]

Ok, your original code works, just me being silly!. 2 further things please.

1. Like I said I need a space adding when it copies the data in the X column from the deleted rows.

2. Can I select further columns to do like it does with X? i.e add the data from column K or H or all 3 of them etc..?

Thanks.

1. Add a space where?
2. Yes. But in light of earlier discussion please clarify what you mean by "select". Are you looking for example of adding values in cols K and H as well as X, but based on duplicates in Column A?
3. Does it not work for that formulation of column A? I tested the earlier (select) version, but not the column A modification.
4. Incidentally, if you've got a lot of data the above code should run much faster than one based on line-by line-deletion.

 

[Dazzawm]

Yes the original code works ok when I select the column. Point 1 When the data is added to the remaining row from X it joins the data together i.e if ABC is in the existing row and DEF is added to it it ends up ABCDEF instead of ABC DEF. In answer to your second point - Yes! The actually columns will be S, V and X.

Thanks

 

[mirabeau]

So, it was concatenation rather than numerical addition that you wanted.

Change the line

xcol(d(x)) = xcol(d(x)) + xcol(i)

to

xcol(d(x)) = xcol(d(x)) & " " & xcol(i)