Copy conditional unique values

elektor · Jun 12, 2011

I need a macro to scan Sheets("Stock")(Range("A2:A" & x) , if Sheets("Stock").Cells(x, 2) > 0 then copy unique value of Sheets("Stock")(Range("A2:A" & x) to Sheets("Result").Range("A" & y).

I wrote this macro but it doesn’t run properly. Sometimes it doesn’t copy unique values.

Sub Copy()
Dim x, y As Long
Sheets("Result").Range("A1:A500") = ""
y = 2
For x = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("A2:A" & x), Cells(x, 1)) = 1 Then
If Sheets("Stock").Cells(x, 2) > 0 Then
Sheets("Result").Range("A" & y) = Sheets("Stock").Cells(x, 1).Value
y = y + 1
End If
End If
End Sub
[FONT=&quot] [/FONT]
[FONT=&quot]Is there any way to fix this?[/FONT]Thanks for all the help!

MickG · Jun 12, 2011

I think this line :=

Code:

If WorksheetFunction.CountIf(Range("A2:A" & x), Cells(x, 1)) = 1 Then

Should be somthing like this:-
Where 500 is the extent of the rows in your range

Code:

If WorksheetFunction.CountIf(Range("A2:A500"), Cells(x, 1)) = 1 Then

elektor · Jun 12, 2011

Thanks to reply but this isn’t the problem. Sheets("Result").Range("A1:A500") is enough for me.
I try to explain the problem:

A B
1 Banana 2
2 Apple -3
3 Banana 1
4 Apple 3

The macro doesn’t copy apple to Sheets("Result") due to first Apple is negative in cell B2. But I need to copy Apple to Sheets("Result") because there is a positive Apple value found in cell B4.

MickG · Jun 12, 2011

Try this:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG12Jun39
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Stock")
[COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A1"), .Range("A" & rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Dn(, 2) > 0 [COLOR="Navy"]Then[/COLOR] .Item(Dn.value) = Dn.value
    [COLOR="Navy"]Next[/COLOR]
Sheets("Results").Range("A1").Resize(.Count) = Application.Transpose(.keys)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

elektor · Jun 12, 2011

Thanks MickG. This is exactly what I want.

elektor · Jun 12, 2011

When I canged this code:

MickG said:

Like this:

Code:

[COLOR=Navy]Set[/COLOR] Rng = .Range(.Range("I4"), .Range("I" & rows.Count).End(xlUp))

Type nismatch error occurs. Can you fix this?

elektor · Jun 12, 2011

And I want to use "e" column instead of "b". How does readjust this macro?

MickG · Jun 13, 2011

Can you clarify which 2 columns you intend to use, is it "A" for Fruits "E" for Numbers, and where does column "I" come in. Please clarify.

elektor · Jun 13, 2011

MickG said:
Can you clarify which 2 columns you intend to use, is it "A" for Fruits "E" for Numbers, and where does column "I" come in. Please clarify.

When I use “A” for fruits and “B” for numbers, the macro runs perfectly.
But I have to use ” I“ for fruits and “E” for numbers. When I use “I” and “E”, the macro gives an error.
By the way, thanks for your interest.

MickG · Jun 14, 2011

Try this:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG14Jun26
[COLOR="Navy"]Dim[/COLOR] rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Stock")
[COLOR="Navy"]Set[/COLOR] rng = .Range(.Range("I4"), .Range("I" & rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] rng
        '[COLOR="Green"][B]NB:- Dn.offset(,-4) = 4 columns to the left of column "I"[/B][/COLOR]
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, -4) > 0 [COLOR="Navy"]Then[/COLOR] .Item(Dn.value) = Dn.value
    [COLOR="Navy"]Next[/COLOR]
Sheets("Results").Range("A1").Resize(.Count) = Application.Transpose(.keys)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

Copy conditional unique values

elektor

New Member

Excel Facts

MickG

MrExcel MVP

elektor

New Member

MickG

MrExcel MVP

elektor

New Member

elektor

New Member

elektor

New Member

MickG

MrExcel MVP

elektor

New Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

Copy conditional unique values

New Member

Excel Facts

MrExcel MVP

New Member

MrExcel MVP

New Member

New Member

New Member

MrExcel MVP

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock