http://excel-user.blogspot.com/2009/10/highlight-duplicates.html
jppinto
sub delete_dups()
dim c1 as range
dim c2 as range
for each c1 in range("A1:A" & range("A" & range("A:A").rows.count).end(xlup).row)
for each c2 in range("A" & c1.row & ":A" & range("A" & range("A:A").rows.count).end(xlup).row)
if c1.value = c2.value and c1.offset(0,3).value = c2.offset(0,3).value then
c2.delete
end if
next
next
end sub
ub delete_dups()
dim c1 as range
dim c2 as range
dim cnt as long
cnt = 1
dim ws1 as worksheet
dim ws 2 as worksheet
set ws1 = sheet1
set ws2 = sheet2
for each c1 in ws1.range("A1:A" & ws1.range("A" & ws1.range("A:A").rows.count).end(xlup).row)
for each c2 in ws1.range("A" & c1.row & ":A" & ws1.range("A" & ws1.range("A:A").rows.count).end(xlup).row)
if c1.value = c2.value and c1.offset(0,3).value = c2.offset(0,3).value then
c1.entirerow.copy ws2.range("A" & cnt)
cnt = cnt + 1
c2.entirerow.copy ws2.range("A" & cnt)
cnt = cnt + 1
end if
next
next
end sub
Sub x()
Dim rData As Range
Application.ScreenUpdating = False
With Sheets("data")
With .Range("A1").CurrentRegion
.Offset(1, .Columns.Count).Resize(.Rows.Count - 1, 1).Formula = "=SUMPRODUCT((" & .Columns(1).Address & "=A2)*(" & .Columns(4).Address & "=D2))"
End With
.AutoFilterMode = False
.Range("A1").AutoFilter Field:=.Range("A1").CurrentRegion.Columns.Count, Criteria1:=2
With .AutoFilter.Range
On Error Resume Next
Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rData Is Nothing Then
rData.Resize(, rData.Columns.Count - 1).Copy Sheets("after copy").Range("A1")
rData.EntireRow.Delete
End If
End With
.AutoFilterMode = False
With .Range("A1").CurrentRegion
.Columns(.Columns.Count).Clear
End With
End With
Application.ScreenUpdating = True
End Sub
Sub delete_dups()
Dim c1 As Range
Dim c2 As Range
Dim cnt As Long
cnt = 1
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2
For Each c1 In ws1.Range("A1:A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Row = ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row Then
Exit Sub
End If
For Each c2 In ws1.Range("A" & c1.Row + 1 & ":A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Value = c2.Value And c1.Offset(0, 3).Value = c2.Offset(0, 3).Value Then
c1.EntireRow.Copy ws2.Range("A" & cnt)
cnt = cnt + 1
c2.EntireRow.Copy ws2.Range("A" & cnt)
cnt = cnt + 1
GoTo nxt
End If
Next
nxt:
Next
End Sub
Sub delete_dups()
Dim c1 As Range
Dim c2 As Range
Dim cnt As Long
cnt = 1
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2
For Each c1 In ws1.Range("A1:A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Row = ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row Then
Exit Sub
End If
For Each c2 In ws1.Range("A" & c1.Row + 1 & ":A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Value = c2.Value And c1.Offset(0, 3).Value = c2.Offset(0, 3).Value Then
c1.EntireRow.Copy ws2.Range("A" & cnt)
cnt = cnt + 1
GoTo nxt
End If
Next
nxt:
Next
End Sub
sub delete_dups()
Dim c1 As Range
Dim c2 As Range
Dim cnt As Long
cnt = 1
Dim ws1 As Worksheet
Dim ws2 As Worksheet
dim origcopy as boolean
Set ws1 = Sheet1
Set ws2 = Sheet2
origcopy = false
For Each c1 In ws1.Range("A1:A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Row = ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row Then
Exit Sub
End If
For Each c2 In ws1.Range("A" & c1.Row + 1 & ":A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Value = c2.Value And c1.Offset(0, 3).Value = c2.Offset(0, 3).Value Then
if origcopy = false then
c1.EntireRow.Copy ws2.Range("A" & cnt)
origcopy = true
cnt = cnt + 1
end if
c2.EntireRow.Copy ws2.Range("A" & cnt)
cnt = cnt + 1
End If
Next
origcopy = false
Next
End Sub
Sub delete_dups()
Dim c1 As Range
Dim c2 As Range
Dim cnt As Long
cnt = 1
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim origcopy As Boolean
Set ws1 = Sheet1
Set ws2 = Sheet2
origcopy = False
For Each c1 In ws1.Range("A1:A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.EntireRow.Interior.Color = vbRed Then
c1.EntireRow.Interior.Color = xlNone
GoTo nxt
End If
If c1.Row = ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row Then
Exit Sub
End If
For Each c2 In ws1.Range("A" & c1.Row + 1 & ":A" & ws1.Range("A" & ws1.Range("A:A").Rows.Count).End(xlUp).Row)
If c1.Value = c2.Value And c1.Offset(0, 3).Value = c2.Offset(0, 3).Value Then
If origcopy = False Then
c1.EntireRow.Copy ws2.Range("A" & cnt)
origcopy = True
cnt = cnt + 1
End If
c2.EntireRow.Copy ws2.Range("A" & cnt)
c2.EntireRow.Interior.Color = vbRed
cnt = cnt + 1
End If
Next
origcopy = False
nxt:
Next
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Chocolatey under PowerShell is not working properly | 3 | 44 | |
vbModal | 12 | 31 | |
Excel for Mac - How make those Tabs larger? | 2 | 31 | |
Automating Excel Weekly Report | 13 | 50 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
12 Experts available now in Live!