菜鸟求助大神帮忙解决分类自动复制问题，诚心求助，谢谢。

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