Merge unique IDs of varying amounts

[carpoto]

I am looking for a method of "merging"/matching up various unique IDs into one table. I frequently have data that look like this:

Col1 Col2 Col3
n01 n02 n24
n02 n03 n20
n03 n05 n15
n04 n01 n05
n05 n20 n03
n06 n09 n10
n07 n14 n02
n08 n15 n07
n09 n10
n10 n08
n11 n11
n12 n16
n13 n07
n14 n23
n15 n24

My data sometimes but do not always have all of one column in the next column (column 3 has less data in it than column 1 or 2).

I want to be able to put them all together into one table where the cells are sorted and spaced properly, like this:

Col1 Col2 Col3
n01 n01
n02 n02 n02
n03 n03 n03
n04
n05 n05 n05
n06
n07 n07 n07
n08 n08
n09 n09
n10 n10 n10
n11 n11
n12
n13
n14 n14
n15 n15 n15
n16
n20 n20
n23
n24 n24

The ways I used to do this was by copying Col2 into a new column and then removing duplicates (new feature in Excel 2007) of the new column from Col1 and then using the uniques left to remove the uniques from Col2 leaving me with only duplicates, and then just sorting it. Then repeat that for Col3. If there is a quicker or less error prone method then I would be very happy!

Can anyone offer guidance? Thanks very much!

 

[Legacy 68668]

try

Sub test()
Dim a, e, b(), i As Long, ii As Long, n As Long
a = Range("a1").CurrentRegion.Resize(, 3).Value
ReDim b(1 To UBound(a, 1) * 3, 1 To 3)
With CreateObject("Scripting.Dictionary")
    For Each e In a
        If (e <> "") * (Not .exists(e)) Then
            n = n + 1 : b(n, 1) = e : .item(e) = n
        End If
    Next
    For ii = 2 To UBound(a, 2)
        For i = 1 To UBound(a, 1)
            If a(i, ii) <> "" Then b(.item(a(i, ii)), ii) = a(i, ii)
    Next i, ii
End With
Range("a1").Resize(n, 3).Value = b
End Sub

 

[carpoto]

Thanks for answering my question. Your solution was very close, but not exact. It provided me with:

Col1 Col2 Col3
n01 n01
n02 n02 n02
n03 n03 n03
n04
n05 n05 n05
n06
n07 n07 n07
n08 n08
n09 n09
n10 n10 n10
n11 n11
n12
n13
n14 n14
n15 n15 n15
n20 n20 n20
n16 n16
n23 n23
n24 n24 n24


It added information into Column 1 (n20, n16, n23, n24 were all added into it). It also didn't sort it properly, but that's not imperative (I can do that after the fact if necessary).

I'm very impressed overall with the code, though. Thanks so far!

 

[carpoto]

EDITED (I took longer than 10 minutes so I had to create a new post):
Reason for editing: I had an error in my original post

I see that the mistake was my fault! I incorrectly indicated in my original post that Col1 should have those extra values. I'm not sure why I did that. The point of me sorting these is to find what values are in each column (and what are missing in each) and adding extra values to any column is introducing error. Sorry! What I am actually looking for is this:


Col1 Col2 Col3
n01 n01
n02 n02 n02
n03 n03 n03
n04
n05 n05 n05
n06
n07 n07 n07
n08 n08
n09 n09
n10 n10 n10
n11 n11
n12
n13
n14 n14
n15 n15 n15
n16
n20 n20
n23
n24
n24

 

[Legacy 68668]

change

Range("a1").Resize(n, 3).Value = b

to

With Range("a1").Resize(n, 3)
    .Value = b
    .Sort .Cells(1, 1), 1
End With

 

[carpoto]

Thanks, that change fixed the sorting issue. However, it didn't get rid of the duplicates that get entered into the first column, which I just realized is getting changed for the way the forum formats my columns!

What I (really) am looking for is this:

Col1	Col2	Col3
n01	n01	
n02	n02	n02
n03	n03	n03
n04		
n05	n05	n05
n06		
n07	n07	n07
n08	n08	
n09	n09	
n10	n10	n10
n11	n11	
n12		
n13		
n14	n14	
n15	n15	n15
       	n16	
      	n20	n20
      	n23	
      	n24	n24

I don't know how I got it wrong the second time, but this is the correct result. [EDITED: I do know now, the forum removed the spaces which is fixed now that I put it in code form] I want all columns to retain their original information after being re-ordered and sorted.

Thanks again for all your help. I've learned a lot already!

 

[Legacy 68668]

Sub test()
Dim a, w(), i As Long, ii As Long, x, e
a = Range("a1").CurrentRegion.Resize(, 3).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For ii = 1 To UBound(a, 2)
        For i = 1 To UBound(a, 1)
            If a(i, ii) <> "" Then
                If Not .exists(a(i, ii)) Then
                    ReDim w(1 To 3) : w(ii) = a(i, ii)
                    .item(a(i, ii)) = w
                Else
                    w = .item(a(i, ii)) : w(ii) = a(i, ii)
                    .item(a(i, ii)) = w
                End If
            End If
        Next
    Next
    x = .keys
    SortA x, 0, UBound(x)
    For Each e In x
        w = .item(e)
        Range("a1").Offset(n).Resize(, 3).Value = w
        n = n + 1
    Next
End With
End Sub
 
Private Sub SortA(ary, LB, UB)
 Dim M As Variant, i As Long, ii As Long, temp
 i = UB : ii = LB
 M = UCase(ary(Int((LB + UB)/2)))
 Do While ii <= i
      Do While UCase(ary(ii)) > M
           ii = ii + 1
      Loop
      Do While UCase(ary(i)) < M
           i = i - 1
      Loop
      If ii <= i Then
           temp = ary(ii) : ary(ii) = ary(i) : ary(i) = temp
           ii = ii + 1 : i = i - 1
      End If
 Loop
 If LB < i Then SortA ary, LB, i
 If ii < UB Then SortA ary, ii, UB
 End Sub