Finding Matching Cells Across Columns and then Sorting

[ExitToDOS]

Hello.

I have a worksheet on which data is listed in three columns: A, B and C. The data in each column is unique, in that a value will only appear once in that column. However, that value may also appear in one or both of the other columns.

If possible, I would like to sort the worksheet so that the rows which match across all three columns appear at the top, followed by rows which match across two of the three columns, and lastly, with the unique rows appearing at the bottom.

Here is an example of the unsorted list:

Col A | Col B | Col C
Green | Blue | Yellow
Blue | Yellow | Green
Yellow | Green | Blue
Red | Purple | White
White | Red | Brown
Orange
Pink

And here is an example of the sorted list:

Col A | Col B | Col C
Green | Green | Green
Blue | Blue | Blue
Yellow | Yellow | Yellow
Red | Red
White | White
Orange | Purple | Brown
Pink

Any ideas? Thanks in advance.

 

[sweater_vests_rock]

jindon.

sorry, i should have added my expected result:

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	a	d	b		a	a	a		a	a	a
2	b	a	c		b	b			b		b
3	c		a		c	c			c		c
4	d				d	d			d	d
5
6	EntereddataA1:C4				MacroreturneddataE1:G4				ExpecteddataI1:K4
Sheet1

could you get to that solution from here, or would it take a lot of reworking?

cheers. ben.

 

[jindon]

ben,

Can you post the screen shots again please?

 

[sweater_vests_rock]

posted.

 

[jindon]

This is limited only max of 3 dups for each item
try

Sub test()
Dim a, dic As Object, i As Long, b(), ii As Byte, n As Long
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Range("a1").CurrentRegion.Resize(,3).Value
ReDim b(1 To UBound(a,1), 1 To 3)
For i = 1 To UBound(a,1)
    For ii = 1 To 3
        If Not IsEmpty(a(i,ii)) Then
            If Not dic.exists(a(i,ii)) Then
                n = n + 1
                x = 1
                dic.add a(i,ii), n
            Else
                If i = dic(a(i,ii)) Then
                    x = IIf(b(dic(a(i,ii),2)="",2,3)
                Else
                    x = IIf(b(dic(a(i,ii)),3)="",3,2)
                End If
                b(dic(a(i,ii)),x) = a(i,ii)
            End If
        End If
     End If
Next
With Range("e1")
   .CurrentRegion.ClearContents
   .Resize(n,3).Value = b
End With
End Sub

 

[agihcam]

different approach;

Sub sample1()
Dim i, ii, mrow As Long
Application.ScreenUpdating = False
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    With Columns("b")
        Set c = .Find(Cells(i, "a").Value, , , xlWhole)
            If Not c Is Nothing Then
                Cells(i, "d").Value = c.Value
                c.ClearContents
            End If
    End With
    With Columns("c")
        Set c = .Find(Cells(i, "a").Value, , , xlWhole)
            If Not c Is Nothing Then
                Cells(i, "e").Value = c.Value
            c.ClearContents
            End If
    End With
Next
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    If Cells(i, "a").Value <> Cells(i, "d").Value And Cells(i, "a").Value <> Cells(i, "e").Value Then
        ii = Cells(i, "a").Row
        Exit For
    End If
Next
mrow = ii
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    If Not IsEmpty(Cells(i, "b").Value) Then
        Range("d" & mrow).Value = Cells(i, "b").Value
        mrow = mrow + 1
    End If
Next
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    If Not IsEmpty(Cells(i, "c").Value) Then
        Range("e" & ii).Value = Cells(i, "c").Value
        ii = ii + 1
    End If
Next
Columns("b:c").Delete
Application.ScreenUpdating = True
End Sub

 

[jindon]

ben,

I"ve just took a look at your result again and is it simply like this?

Sub test()
Dim a, i As Long, ii As Byte, b(), n As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Range("a1").CurrentRegion.Resize(,3).Value
ReDim b(1 To UBound(a,1), 1 To 3)
For i = 1 To UBound(a,1)
    If Not IsEmpty(a(i,1)) And Not dic.exists(a(i,1)) Then
            n = n + 1
            dic.add a(i,1), n
    End If
Next
For i = 1 To UBound(a,1)
    For ii = 2 To 3
        If dicexists(a(i,ii)) Then
            b(dic(a(i,ii)),ii)=a(i,ii)
        End If
    Next
Next
With Range("e1")
    .CurrentRegion.ClearContents
    .Resize(n,3).Value = b
End With
Set dic = Nothing
End Sub

 

[sweater_vests_rock]

jindon.

seems to do it, after fixing a few typos. it looks like this should be pretty easy to expand to a user-selected range for a single column "custom sort" -- but is this similarly easy to expand to sorting a multi-column range on a single key column?

i'm not familiar with the dictionary object, although i've seen it used on the site (i know you're a big fan )

thanks. ben.

 

[jindon]

ben,
How about this?

Sub test()
Dim rng As Range,a, ColRef As Integer, dest As Range
Set rng = Application.InputBox("Click on a cell in the range",type:=8)
Col = Applidcation.Inputbox("Enter Key col. count from the leftmost column, type:=1)
Set dest = Application.Inputbox("Click on a cell to display",type:=8)
If Col > rng.CurrentRegion.Columns.Count Then
    MsgBox "Col ref is Out Of Bounds"
    Exit Sub
End If
mySort a, ColRef
dest.Cells(1,1).Resize(UBound(a,1),UBound(a,2)).Value = a
Set rng = Nothing : Set dest = Nothing
End Sub

Sub mySort(a, ColRef As Integer)
Dim i As Long, ii As Integer, b(), n As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
ReDim b(1 To UBound(a,1), 1 To UBound(a,2))
For i = 1 To UBound(a,2)
    If Not dic.exists(a(i,ColRef)) Then
            dic.add a(i,ColRef), i
    End If
Next
For i = 1 To UBound(a,1)
    For ii = 1 To UBound(a,2)
        If ii <> ColRef Then
            If dic.exists(a(i,ii)) Then
                b(dic(a(i,ii)),ii)=a(i,ii)
            End If
        End If
    Next
Next
a = b
Set dic = Nothing
End Sub

 

[sweater_vests_rock]

hi jindon.

i've been working with your suggestion, and i can almost see what i need to get there, but not quite.

in my code below, i've seperated the idea of the "key" and the range to sort. i don't understand enough about the Scripting.Dictionary object to understand how to work it given that i now have two arrays instead of your single a array.

thoughts?
ben.

Sub CustomSort()

    Dim rngSort As Range
    Dim wsOutput As Worksheet
    Dim ColRef As Integer
    Dim aryKey As Variant, arySort As Variant
    
'   Get range to rearrange from user and load into an array
    Set rngSort = Application.InputBox("Select the range to rearrage:", Type:=8)
    arySort = rngSort
    
'   Get sort key from user
    Set rngKey = Application.InputBox("Select the sort key column: ", Type:=8)
    Set rngKey = Intersect(rngKey.EntireColumn, ActiveSheet.UsedRange)
    aryKey = rngKey
    
'   Create new sheet to output sorted data
    Set wsOutput = Worksheets.Add
    rngSort.Parent.Activate

    mySort aryKey, arySort
    
'   Print results to new sheet
    wsOutput.Cells(1, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
    
'   Empty object variables
    Set rngSort = Nothing
    Set wsOutput = Nothing

End Sub

Sub mySort(Key, Sort)
    Dim i As Long, ii As Integer, b(), n As Long, dic As Object
    
'   Instance dictionary object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    
    For i = 1 To UBound(Key, 1)
        If Not dic.exists(Key(i, 1)) Then dic.Add Key(i, 1), i
    Next i

    For i = 1 To UBound(a, 1)
        For ii = 1 To UBound(a, 2)
            If ii <> ColRef Then
                If dic.exists(a(i, ii)) Then
                    b(dic(a(i, ii)), ii) = a(i, ii)
                End If
            End If
        Next ii
    Next i

    a = b
    Set dic = Nothing
End Sub

ben,
How about this?

Sub test()
Dim rng As Range,a, ColRef As Integer, dest As Range
Set rng = Application.InputBox("Click on a cell in the range",type:=8)
Col = Applidcation.Inputbox("Enter Key col. count from the leftmost column, type:=1)
Set dest = Application.Inputbox("Click on a cell to display",type:=8)
If Col > rng.CurrentRegion.Columns.Count Then
    MsgBox "Col ref is Out Of Bounds"
    Exit Sub
End If
mySort a, ColRef
dest.Cells(1,1).Resize(UBound(a,1),UBound(a,2)).Value = a
Set rng = Nothing : Set dest = Nothing
End Sub

Sub mySort(a, ColRef As Integer)
Dim i As Long, ii As Integer, b(), n As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
ReDim b(1 To UBound(a,1), 1 To UBound(a,2))
For i = 1 To UBound(a,2)
    If Not dic.exists(a(i,ColRef)) Then
            dic.add a(i,ColRef), i
    End If
Next
For i = 1 To UBound(a,1)
    For ii = 1 To UBound(a,2)
        If ii <> ColRef Then
            If dic.exists(a(i,ii)) Then
                b(dic(a(i,ii)),ii)=a(i,ii)
            End If
        End If
    Next
Next
a = b
Set dic = Nothing
End Sub

 

[jindon]

ben

I think I understand what you want to do, but

Problem

If key column includes blanks, how the data should be sorted?
e.g

1   2   3   4   5   6   7 
A   B   C  D   E   F   G
    A   F      A   B   C
    D      F    G  C  B

Say, if the key column is "1", how the data should be ordered?