Sub Test()

    Dim rowsNum, i, j, equalRowsNum As Integer

    rowsNum = ActiveSheet.UsedRange.Rows.Count '获得行数

    For i = 3 To rowsNum '遍历全部行数

     If Cells(i, 1).Value = Cells(i + 1, 1).Value Then

        j = j + 1

    Else

        For equalRowsNum = 1 To j

        '给指定列追加数值。把相同行的同列追加到第一相同行

        Cells(i - j, 6).Value = CStr(Cells(i - j, 6).Value) + Chr(10) + CStr(Cells(i - j + equalRowsNum, 6).Value)

        Next

        j = 0

     End If

    Next

    'Debug.Print rowsNum

End Sub