hello,
I have thousands of records in my table: in column A many duplicate values, I would need to get only those unique values from column A which have different values in column B (ignore the same values in column B for corresponding value in A):
A B 1 a 1 a 2 b 2 b 2 c 3 d 3 d 4 a 4 b
so as a result from example above, I should get only 2 and 4 on my list.
I was browsing for couple of of hours but couldn't find any solution. I guess loop is needed, but I am quite novice.
thanks
Code:Option Explicit
Sub test()
Dim r As Range
Dim a As Range
Dim c As Range
Dim d As Object
Set r = Cells(1).CurrentRegion
With r.Columns(3)
.Formula = "=if(countifs(a:a,a1,b:b,b1)>1,1)"
On Error Resume Next
Set a = .SpecialCells(xlCellTypeFormulas, 4)
On Error GoTo 0
.ClearContents
End With
If a Is Nothing Then Exit Sub
Set d = CreateObject("scripting.dictionary")
For Each c In a
d(c.Offset(, -2).Value) = True
Next
MsgBox Join(d.keys, vbLf)
End Sub
thank you. I t works for the simple example I provided above. Unfortunately doesn't work for me, Could it be possible to return results in new sheet? I do not know if this is important: column A contains numbers in the format00-0000000000-00-0000 and column B numbers and text (sometimes very long) let's say it's a list of 30 standard sentences which then appear in combinations:
A B 1.test1 2.test2 1.test1 2.test2 3.test3 3.test3 1.test1 3.test3 5.test5 6.test6 5.test5 7.test7 3.test3
Code:Option Explicit
Sub test2()
Dim r As Range
Dim a As Range
ActiveSheet.Copy
With Cells(1).CurrentRegion.Columns("c")
.Formula = "=if(countifs(a:a,a1,b:b,b1)=1,1)"
On Error Resume Next
Set a = .SpecialCells(xlCellTypeFormulas, 4)
On Error GoTo 0
End With
If Not a Is Nothing Then a.EntireRow.Delete
Columns("b:c").ClearContents
Columns("a").RemoveDuplicates 1
End Sub
Try:Quote:
Originally Posted by czarmir
Note various possibilities in comments in the codeCode:Sub blah()
Set myrng = Range(Cells(1), Cells(Rows.Count, 1).End(xlUp)) 'assumes start in A1 and end bottommost cell with anything in in column A.
'Set myRng = Selection 'use this instead of the line above if you want (select 2 columns of cells before running this macro).
With Sheets.Add(after:=Sheets(Sheets.Count))
.Cells(1).Resize(myrng.Rows.Count).Value = Evaluate("IF(COUNTIFS(" & myrng.Columns(1).Address(external:=True) & "," & myrng.Columns(1).Address(external:=True) & "," & myrng.Columns(2).Address(external:=True) & ",""<>"" & " & myrng.Columns(2).Address(external:=True) & ")>0," & myrng.Columns(1).Address(external:=True) & ","""")")
.Cells(1).Resize(myrng.Rows.Count).RemoveDuplicates Columns:=1, Header:=xlNo
' .Columns(1).AutoFit 'uncomment this line if you want adjusted column width.
' .UsedRange.Sort key1:=.Cells(1), Header:=xlNo 'optional to sort list (additionally any empty cell will go to the bottom of the list).
End With
End Sub
hi,
thanks for your help. But still doesn't work for me. I attached part of my data. Out of this sheet I should get in a new sheet: only two values from column A for which values in column B are different (just one value from rows 5-7 and another from 13-15. Rows 21 and 22 (the same values in col. B) and other unique values in column A should be ignore.
regards
Are the extra ones on rows 77 and 98?
If so, it turns out that there is a 255 or 256 character limit for Countif(s). B77 and B98 both contain strings longer than 256 characters.
Could you confirm these are the errant results?
This seems to get round the problem:Note that if there are ever likely to be more than 65k results on the new sheet we'll have to rethink that last line!Code:Sub blah()
Set myRng = Range(Cells(1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 2) 'assumes start in A1 and end bottommost cell with anything in in column A.
'Set myRng = Selection 'use this instead of the line above if you want (select 2 columns of cells before running this macro).
myVals = myRng.Value
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(myVals) - 1
c1 = myVals(i, 1)
If Not dic.exists(c1) Then 'if c1 not already in dictionary:
c2 = myVals(i, 2)
For j = i + 1 To UBound(myVals)
If myVals(j, 1) = c1 And myVals(j, 2) <> c2 Then
'add to dictionary:
dic(c1) = True
Exit For
End If
Next j
End If
Next i
Sheets.Add(after:=Sheets(Sheets.Count)).Cells(1).Resize(dic.Count).Value = Application.Transpose(dic.keys)
End Sub
re:Looks like you were right!Quote:
Originally Posted by czarmir
hi,
I randomly verified results with my sheet of 4000+ rows and it seems to be working as expected.
so big thanks for your help!