How to create a macro to move duplicates
Category: [Excel] Demo Available
How to create a macro to move duplicates
Requirement:
Column B contains alpha-numeric values and the user needs a formula or macro which will move the duplicates, search and move complete row once duplicate value is found in column B.
https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1195844-move-duplicates
Solution:
Code:
Sub MoveDupsAndKeepFirst()
Dim r As Range, c As Range, cn As Integer, lr As Long, col$
Dim wsU As Worksheet, wsD As Worksheet, rr As Range
Set wsU = Worksheets("Uniques")
Set wsD = Worksheets("Duplicates")
col = "B"
With wsU
Set rr = .UsedRange
Set r = .Range(col & 2, .Cells(Rows.Count, col).End(xlUp))
cn = rr.Columns.Count
lr = r.Rows.Count + 1
'H2=COUNTIF(B$2:B$8,"=" & B2)-COUNTIF(B2:B$8,"=" & B2)
.Cells(r.Row, cn + 1).Formula = "=COUNTIF(" & col & "$2:" & col & "$" & lr & "," & """" & "=" & """" & _
"&" & col & "2)-COUNTIF(" & col & "2:" & col & "$" & lr & "," & """" & "=" & """" & "&" & col & "2)"
.Cells(r.Row, cn + 1).Copy r.Offset(, cn - 1)
'Filter, copy, and delete filtered rows.
.UsedRange.AutoFilter cn + 1, ">0"
With Intersect(StripFirstRow(.AutoFilter.Range.SpecialCells(xlCellTypeVisible)), rr)
.Copy wsD.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Delete xlUp
End With
.AutoFilterMode = False
Intersect(.UsedRange, .Columns(cn + 1)).Delete 'Delete helper column
End With
Application.CutCopyMode = False
End Sub
Function StripFirstRow(aRange As Range) As Range
Dim i As Long, j As Long, r As Range, z As Long, idx As Long
For i = 1 To aRange.Areas.Count
For j = 1 To aRange.Areas(i).Rows.Count
z = z + 1
If z = 1 Then GoTo NextJ
If r Is Nothing Then
Set r = aRange.Areas(i).Rows(j)
Else
Set r = Union(r, aRange.Areas(i).Rows(j))
End If
NextJ:
Next j
Next i
Set StripFirstRow = r
End Function
Obtained from the OzGrid Help Forum.
Solution provided by Kenneth Hobson.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to copy a sheet and rename from a list, ignore duplicates |
| How to use IndexMatch formula that ignores duplicates |
| How to find sequence of a column with duplicates |
| How to compare two workbooks with multiple sheets and highlighting duplicates |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.