Option Explicit
Sub test()
Dim arr, dic(2), i, j, key, m, t
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = [a1].CurrentRegion
For i = 1 To UBound(arr, 1)
dic(0)(arr(i, 1)) = i
dic(1)(arr(i, 2)) = i
Next
ReDim brr(1 To dic(0).Count + dic(1).Count + 1, 1 To dic(0).Count + dic(1).Count + 1)
For i = 0 To UBound(dic)
For Each key In dic(i)
m = m + 1
brr(m + 1, 1) = key
brr(1, m + 1) = key
Next key, i
For i = 2 To UBound(brr, 1)
For j = 2 To UBound(brr, 2)
dic(2)(brr(i, 1) & brr(1, j)) = Array(i, j)
brr(i, j) = 0
Next j, i
For i = 1 To UBound(arr, 1)
If dic(2).exists(arr(i, 1) & arr(i, 2)) Then
t = dic(2)(arr(i, 1) & arr(i, 2))
brr(t(0), t(1)) = 1
End If
If dic(2).exists(arr(i, 2) & arr(i, 1)) Then
t = dic(2)(arr(i, 2) & arr(i, 1))
brr(t(0), t(1)) = 1
End If
Next
[e1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub |