Private Sub CommandButton1_Click()

Dim i%, K%

Dim d As Object

Range("D2:F11").ClearContents

Set d = CreateObject("Scripting.Dictionary")

    For i = 2 To 11

        If d.Exists(Cells(i, 1).Value) = False Then             d.Add Cells(i, 1).Value, 1              Cells(d.Count + 1, "D") = d.Count '给不重复加序号             Cells(d.Count + 1, "e") = Cells(i, 1) '列出不重复项             Cells(d.Count + 1, "F") = Cells(i, 2) '列出不重复第一次的B列数值         Else         K = Application.Match(Cells(i, 1), d.keys, 0) '找到重复项的索引          Cells(K + 1, "F") = Cells(K + 1, "F") + Cells(i, 2) '累加数值         End If     Next i

End Sub