Delete Duplicate Records

B

BatMan

I 'm looking for a macro that will delete duplicate rows. For example my
data has PO# in column A shipper # in column B and date in C. If row 2 has
the exact same data as row 1 delete row 2 then continue to evaluate
stepping through the file until the end.


Any help on where to start would be greatly appreciated.
 
S

Simon Lloyd

Well rather than a start here's some code that will do the trick, o
course you may have to adapt it to your particular situation!

Simon

Here's the code........

Sub RemoveDuplicateCells()
Dim Myrange As Range
Dim C As Range
Dim DelRange As Range
Dim FindRange
Set Myrange = Intersect(ActiveSheet.UsedRange, Columns("D"))
If Myrange Is Nothing Then Exit Sub
Application.ScreenUpdating = False
FindRange = Array("D", "D", "D")
For Each elem In FindRange
Set C = Myrange.Find(elem, Myrange.Cells(1), xlValues, xlPart)
If Not C Is Nothing Then
If DelRange Is Nothing Then Set DelRange = Rows(C.Row)
firstaddress = C.Address
Do
Set C = Myrange.FindNext(C)
Set DelRange = Union(DelRange, Rows(C.Row))
Loop While firstaddress <> C.Address
End If
Next
Application.ScreenUpdating = True
If DelRange Is Nothing Then Exit Sub
DelRange.Delete shift:=xlUp
End Sub


Public Sub Delete_In_H()
Const MyColumn As Integer = 4
Dim lngRow As Integer
Dim maxRow As Integer

maxRow = Cells(ActiveSheet.Rows.Count, MyColumn).End(xlUp).Row

For lngRow = maxRow To 1 Step -1
If Cells(lngRow, MyColumn).Value = "D" Then

Cells(lngRow, 3).Delete
Cells(lngRow, 4).Delete
Cells(lngRow, 5).Delete
Cells(lngRow, 6).Delete
Cells(lngRow, 7).Delete

End If
Next lngRow
End Su
 
T

Tom Harvey

I had a similar question not long ago. In my case a single cell was enough
to detect that two adjacent rows were duplicates. In other words if column
c had the same value in rows 23 and 24 then I knew that both rows would be
complete duplicates. I got the code shown below from this NG and it worked
for me.

Adjust this to your needs, and it should work...

Sub DeleteDuplicates()
Dim c As Long, r As Long, firstRow As Long, lastRow As Long

c = 3 'this is the column to check for duplicates

firstRow = 2 'this assumes you have headers, if you don't change this to
1
lastRow = Cells(Rows.Count, c).End(xlUp).Row

For r = lastRow To firstRow Step -1
If r > 1 Then
If Cells(r, c) = Cells(r - 1, c) Then
Rows(r).Delete
End If
End If
Next
End Sub

Tom
 
J

Jamie Collins

BatMan said:
I 'm looking for a macro that will delete duplicate rows. For example my
data has PO# in column A shipper # in column B and date in C. If row 2 has
the exact same data as row 1 delete row 2 then continue to evaluate
stepping through the file until the end.
Click to expand...

If your data set is large and you need fast execution, try the
following (change the constant TABLE_NAME_CURRENT from "XXX" to the
name of your worksheet):

Sub Test()

Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim Target As Excel.Range
Dim Con As Object
Dim rs As Object
Dim strCon As String
Dim strPath As String
Dim strSql1 As String
Dim lngCounter As Long

' Amend the following constants to suit
Const TABLE_NAME_CURRENT As String = "" & _
"XXX"
Const FILENAME_XL_TEMP As String = "" & _
"delete_me.xls"
Const TABLE_NAME_NEW As String = "" & _
"MyNewTable"

' Do NOT amend the following constants
Const CONN_STRING_1 As String = "" & _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<PATH><FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=YES'"

' Build connection strings
strPath = ThisWorkbook.Path & _
Application.PathSeparator

strCon = CONN_STRING_1
strCon = Replace(strCon, _
"<PATH>", strPath)
strCon = Replace(strCon, _
"<FILENAME>", FILENAME_XL_TEMP)

' Build sql statement
strSql1 = ""
strSql1 = strSql1 & "SELECT DISTINCT * FROM "
strSql1 = strSql1 & " [" & TABLE_NAME_CURRENT & "$]"

' Delete old instance of temp workbook
On Error Resume Next
Kill strPath & FILENAME_XL_TEMP
On Error GoTo 0

' Save copy of worksheet to temp workbook
Set wb = Excel.Application.Workbooks.Add()
With wb
ThisWorkbook.Worksheets(TABLE_NAME_CURRENT). _
Copy .Worksheets(1)
.SaveAs strPath & FILENAME_XL_TEMP
.Close
End With

' Open connection to temp workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.ConnectionString = strCon
.Open
Set rs = .Execute(strSql1)
End With

Set ws = ThisWorkbook.Worksheets.Add
With ws
.Name = TABLE_NAME_NEW
Set Target = .Range("A1")
End With

With rs
For lngCounter = 1 To .fields.Count
Target(1, lngCounter).Value = _
.fields(lngCounter - 1).Name
Next
End With

Target(2, 1).CopyFromRecordset rs

Con.Close

End Sub


Jamie.

--
 
Top