Sub Macro1()
Dim arr, brr, i&, j%, s&, x%
arr = Range("b33").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
y = UBound(arr) '数组最后一行
For j = 2 To UBound(arr, 2)
x = arr(y, j): s = 0
For i = y - 2 To 1 Step -1 '倒数第三行循环
If arr(i, j) = x Then s = s + 1: brr(s, j - 1) = arr(i + 2, j)
Next
Next
Cells(y + 36, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub