­ã´£³¡ªL

Sub TEST_A1()
Dim Arr, Brr, xD, T$, i&, j%, N&(4)
Set xD = CreateObject("Scripting.Dictionary")
For j = 1 To 3
    Arr = Range(Cells(1, j + 2), Cells(Rows.Count, j + 2).End(xlUp))
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "") = j
    Next i
Next j
'----------------------------------
Arr = Range([a1], Cells(Rows.Count, 1).End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): If T = "" Then GoTo i01
    j = xD(T) + 1: N(j) = N(j) + 1
    Brr(N(j), j) = T
i01: Next i
[g2].Resize(UBound(Brr), 3) = Brr
End Sub