duel criteria seach
 

I want to remove doubles but have 2 different criterias.

first look up mix type
second look up contract number

Here is what I have for a single search

Sub RemoveDuplicates_Mix_Type()

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

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

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

UserForm3.Show

Sheets("test Database").Select
Range("A1").Value = 1

Sheets("test Database_mix").Select
Range("B2").Value = 1
End Sub

and the list box looks like this:


Private Sub ListBox1_Click()

Range("d6").Value = ListBox1


For i = 0 To UserForm3.ListBox1.ListCount - 1
If UserForm3.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("B26:AG500")

ws.AutoFilterMode = False

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

ws.AutoFilter.Range.Copy

Sheets("test database_mix").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

Next

End Sub

Any further help would be appreciated

Eric

duel criteria seach
 

You need to be more specific about what you are trying to do.

--

Regards,
Nigel




"Eric" wrote in message
...
I want to remove doubles but have 2 different criterias.

first look up mix type
second look up contract number

Here is what I have for a single search

Sub RemoveDuplicates_Mix_Type()

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

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

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

UserForm3.Show

Sheets("test Database").Select
Range("A1").Value = 1

Sheets("test Database_mix").Select
Range("B2").Value = 1
End Sub

and the list box looks like this:


Private Sub ListBox1_Click()

Range("d6").Value = ListBox1


For i = 0 To UserForm3.ListBox1.ListCount - 1
If UserForm3.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("B26:AG500")

ws.AutoFilterMode = False

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

ws.AutoFilter.Range.Copy

Sheets("test database_mix").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

Next

End Sub

Any further help would be appreciated

Eric