求教各位大佬

Option Explicit
Sub abc()
　Dim a, i, j
　a = [a1].CurrentRegion.Value
　ReDim d(UBound(a, 2))
　For j = 1 To UBound(a, 2)
　　Set d(j) = CreateObject("scripting.dictionary")
　　For i = 2 To UBound(a)
　　　If Len(a(i, j)) Then
　　　　If j = 1 Then
　　　　　d(j)(a(i, j)) = 1
　　　　Else
　　　　　If d(j - 1).exists(a(i, j)) Then d(j)(a(i, j)) = 1
　　　　End If
　　　End If
　　Next
　　If j > 1 Then
　　　If d(j).Count > 0 Then Cells(2, j + 5).Resize(d(j).Count) = _
　　　　Application.Transpose(d(j).keys)
　　End If
　Next
End Sub