程序代码如下：

Option Explicit

Sub x()
    Dim arr, i&, k$, v$                      '源头
    Dim result(1 To 1000, 1 To 1000), m&, n&, x&, y&  '目标
    '汇总 arr -> sum
    arr = Range("a1").CurrentRegion
    For i = 2 To UBound(arr)
        k = Trim(arr(i, 1))
        v = Trim(arr(i, 2))
        For y = 1 To n
            If result(1, y) = k Then Exit For
        Next y
        If result(1, y) <> k Then
            n = y
            result(1, y) = k
        End If
        For x = 2 To m
            If result(x, y) = "" Then Exit For
        Next x
        result(x, y) = v
        If x > m Then m = x
    Next i
    '保存
    Range("f1").Resize(m, n) = result
End Sub

说明：代码里面的最后一个语句保存结果到F1只是为了便于拷屏展示，存入表2的语句应该是（正常情况还应该添加清除原内容的语句）：
Sheets("表2").Range("a1").Resize(m, n) = result

运行示例：

谢谢大神-阳光下的桥，帮我解决这个难题，也感谢这个平台，让我们在工作中提高了效率。