Remove Duplicates

[Eric]

Hello all,
I am trying to do a remove duplicates based on two seperate criterias. The
first criteria is contract number and the second is mix type. All the
information is on the same page Contract number is in column A and mix type
is in Column B. I am using the remove duplicate macro to determine which
contact I need. Then that contract number (and associated information) is
pasted onto a seperate sheet, this works great, but now I want to enhance
this by removeing all but one mix type for that contract.. Is this possible?

Here is the macro that I am using for the no duplicates of contract numbers.

Sub RemoveDuplicates()

Dim allcells As Range, cell As Range
Dim nodupes As New Collection

On Error Resume Next
For Each cell In Range("A27:A500")
nodupes.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0

For Each item In nodupes
UserForm1.ListBox1.AddItem item
Next item

UserForm1.Show
End Sub
************************************
Private Sub ListBox1_Click()

Range("D6").Value = ListBox1


For i = 0 To UserForm1.ListBox1.ListCount - 1
If UserForm1.ListBox1.Selected(i) Then

Dim ws As Worksheet

Dim rng As Range
Dim rng2 As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set ws = Sheets("Test Database")

Set rng = ws.Range("a26:AC500")

ws.AutoFilterMode = False

rng.AutoFilter field:=1, Criteria1:="=" & ws.Range("D6").Value

ws.AutoFilter.Range.Copy

Sheets("test database2").Select

Range("C500").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, -2).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

ws.AutoFilterMode = False

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
End Sub


Contract number mix type Pb Vtm
#200
1234 1 5.0 4.0
3.2
1234 5 5.0 3.5
2.5
1234 1 4.8 2.5
4.6
456 6 5.0 2.0
1.0

I want to have pasted onto a seperate sheet the following information:

Contract number mix type Pb Vtm
#200
1234 1 5.0 4.0
3.2
1234 1 4.8 2.5
4.6

I thank you in advance for everyones help. Thank you
Eric

 

[Bernd P]

Hello Eric,

Isn't this just what Autofilter does (Data/Filter/Autofilter)?

If yes, you might program in VBA:
1. Copy worksheet
2. Filter and delete what you do NOT want to show.
3. Done

Regards,
Bernd

 

[Eric]

Bernd,

This is slightly different than autofilter in that I paste the data over to
another sheet with no rows in between. In other words, the information will
go from lines 1 to 4 not 1 to 200 and only showing the lines that match the
filter. All this information will be graphed later and it will graph
everything not just what match the filter.
Hope that helps

 

[ryguy7272]

This is what I use:
Sub DeleteDuplicateRows()
Dim lLastRow As Long
Dim lLastCol As Long
Dim i As Long
Dim j As Long
Dim k As Long
lLastRow = ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Columns.Count - 1
For i = 0 To lLastRow - 1
For j = lLastRow To i + 1 Step -1
For k = 0 To lLastCol
If ActiveSheet.Range("A1").Offset(i, k).Value <>
ActiveSheet.Range("A1").Offset(j, k).Value Then
Exit For
End If
Next k
If k > lLastCol Then
ActiveSheet.Range("A1").Offset(j, 0).EntireRow.Delete
End If
Next j
Next i
End Sub


Regards,
Ryan--

 

[ryguy7272]

Ahhh, new information is revealed. Try both of these:
#1
Sub Uniques()
Dim i As Integer
i = 1
Do Until Cells(i, 1).Value = "" '(as long as your data is in column 1)
If Cells(i, 1) = Cells(i + 1, 1) Then
Else
Cells(i, 1).Copy
Cells(i, 5).PasteSpecial xlValues '(this pastes into column E)
End If
i = i + 1

Loop
Range("E5:E1000").Sort Key1:=Range("E5"), Order1:=xlAscending

Columns("E:E").Select
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending ',
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select

End Sub


#2
Sub ExtractUniqueAndSort()
With Sheets("Unique List#1")
..Range("A1:A20").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("E1"), _
Unique:=True

..Range(.Range("E1"), .Range("E1").End(xlDown)) _
..Sort Key1:=.Range("E2"), Order1:=xlAscending, Header:=xlYes
End With
End Sub

I forgot to mention before...try all dupe-deleting macros on sample data!!
Well these last two just copy/paste data into an adjacent column, but the
very first macro that I posted here will actually delete your data in Column
A!!

Regards,
Ryan--