­ã´£³¡ªL

Sub TEST()
Dim Arr, Brr, xD, i&, T1$, T2$, N1&, N2&, R&, C&
ActiveSheet.UsedRange.Offset(, 4).ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([B1], [A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 200)
Brr(1, 1) = "­«½Æ­È"
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1):  T2 = Arr(i, 2)
    If T1 = "" Or T2 = "" Then GoTo 101
    R = xD(T1):  C = xD(T2)
    If R = 0 Then N1 = N1 + 1: R = N1: xD(T1) = N1
    If C = 0 Then N2 = N2 + 1: C = N2: xD(T2) = N2
    Brr(R + 1, 1) = T1:  Brr(1, C + 1) = T2
    Brr(R + 1, C + 1) = T2
101: Next i
If N1 = 0 Or N2 = 0 Then Exit Sub
[E1].Resize(R + 1, C + 1) = Brr
End Sub


================================

­ã´£³¡ªL

¨Sª`·N­n"­«ÂÐ"ªº:
Sub TEST()
Dim Arr, Brr, xD, i&, T1$, T2$, N1&, N2&, R&, C&, U&
ActiveSheet.UsedRange.Offset(, 4).ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([B1], [A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 200)
Brr(1, 1) = "­«½Æ­È"
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1):  T2 = Arr(i, 2)
    If T1 = "" Or T2 = "" Then GoTo 101
    C = xD(T2)
    If C = 0 Then N2 = N2 + 1: C = N2: xD(T2) = C: Brr(1, C + 1) = T2
    U = xD(T1 & "/")
    If U = 0 Then xD(T1 & "/") = C: GoTo 101
    R = xD(T1)
    If R = 0 Then N1 = N1 + 1: R = N1: xD(T1) = R: Brr(R + 1, 1) = T1
    Brr(R + 1, C + 1) = T2
    If U > 0 Then Brr(R + 1, U + 1) = Brr(1, U + 1): U = -99
101: Next i
If N1 = 0 Or N2 = 0 Then Exit Sub
With [E1].Resize(N1 + 1, N2 + 1)
     .Value = Brr
     .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlYes
End With
End Sub


'==========================