macro sorting data

[herwig123]

Hi there,

I got a table with lots of names in column A and numbers in column B. Now I would like to turn this information into two columns, where all names of column A are written next to each other, if they have the same number in column B.

Example


a 1
b 1
c 1
d 2
e 2
f 2


should end up as:

a b
a c
b c
d e
d f
e f

(the same number for a name means there is an interaction between the names - I want all interactions in the final two columns)
Any help to get this in a macro would be appreciated.

cheers

 

[herwig123]

Hi there,

I am quite desperate of getting this done.
I am pretty certain this should be a relatively simple macro for someone who knows their way around excel properly (unfortunately I don't know enough).
Please help

 

[MickG]

Hi, Try this:-
Assumed:-Your Data in Columns "A & B", starting "A1".
Results in Columns "C & D"

Sub JNam()
Dim rng As Range, Dn As Range, Rng2 As Range
Dim n As Long, t As Integer, p As Integer
Dim a, L1 As Integer, L2 As Integer, Ray

Set rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
a = rng.Offset(, -1).Resize(, 2).Value
ReDim Ray(1 To Application.Median(1, rng.Count) * rng.Count, 1 To 2)

With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For Each Dn In rng
          If Not .Exists(Dn.Value) Then
             .Add Dn.Value, 1
         End If
     Next
Dim oVal
For Each oVal In .keys

For L1 = 1 To UBound(a, 1)
    For L2 = 1 + L1 To UBound(a, 1)
          If oVal = a(L1, 2) And oVal = a(L2, 2) Then
                n = n + 1
                Ray(n, 1) = a(L1, 1)
                Ray(n, 2) = a(L2, 1)
                
            End If
    Next L2
Next L1
Next oVal

End With
Range("C1").Resize(n, 2).Value = Ray
End Sub

Regards Mick

 

[herwig123]

You saved my day. This is exactly what I needed. Thanks a lot.

 

[herwig123]

Hi, Try this:-
Assumed:-Your Data in Columns "A & B", starting "A1".
Results in Columns "C & D"

Sub JNam()
Dim rng As Range, Dn As Range, Rng2 As Range
Dim n As Long, t As Integer, p As Integer
Dim a, L1 As Integer, L2 As Integer, Ray

Set rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
a = rng.Offset(, -1).Resize(, 2).Value
ReDim Ray(1 To Application.Median(1, rng.Count) * rng.Count, 1 To 2)

With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For Each Dn In rng
          If Not .Exists(Dn.Value) Then
             .Add Dn.Value, 1
         End If
     Next
Dim oVal
For Each oVal In .keys

For L1 = 1 To UBound(a, 1)
    For L2 = 1 + L1 To UBound(a, 1)
          If oVal = a(L1, 2) And oVal = a(L2, 2) Then
                n = n + 1
                Ray(n, 1) = a(L1, 1)
                Ray(n, 2) = a(L2, 1)
                
            End If
    Next L2
Next L1
Next oVal

End With
Range("C1").Resize(n, 2).Value = Ray
End Sub

Regards Mick

Hi Mick,

I do have one more question after all.
I would like to exclude all rows which have no number in column B. If I understand your macro right you set them to 1 and then they show up in the final 2 columns (C&D). I tried to get rid of that but did not succeed. Could you maybe help again?

 

[MickG]

Hi, Try changing the Similar code line to the line below:-

          If Dn.Value <> "" And Not .Exists(Dn.Value) Then

Regards Mick

 

[herwig123]

Hi, Try changing the Similar code line to the line below:-

          If Dn.Value <> "" And Not .Exists(Dn.Value) Then

Regards Mick

That works perfectly - thanks a lot again