问题如上，

思路：

设计一个行列二维数组，用来逐个存储原始数据，后面存储的数据和数组已存在的数据进行比较，如果已经存在，则合并同类，否则数组添加新值。最后将该二维数组写入到目标区域

细节：

1、 因为是二维数组，而一般动态数组扩容只能改变最末维，所以可以提前定义一个足够大的固定数组；

2、 在元素是否已存在于数组中，采取循环遍历方法，但遍历时会将有值的元素和空元素都进行遍历，为减少循环量，可提前设置循环区域为有效数据区间；

代码：

Sub t()
Dim arr, n, check_return, max_ Row 
Dim rng
 
Sheets(1).Activate
With Sheets(1)
 max_row = [a66356].End(xlUp).Row
 n = max_row
 ReDim arr(1 To n, 1 To 3)
 n = 1
 For Each rng In Range("a2:a" & max_row)
 check_return = check(rng.value, arr, 1)
 If check_return Then
 arr(check_return, 2) = rng.Offset(, 1).value + arr(check_return, 2)
 arr(check_return, 3) = arr(check_return, 3) & "、" & rng.Offset(, 2).value
 Else
 arr(n, 1) = rng.value
 arr(n, 2) = rng.Offset(, 1).value
 arr(n, 3) = rng.Offset(, 2).value
 n = n + 1
 End If
 Next rng
End With
 
Sheets(2).Activate
[a2].Resize(n - 1, 3) = arr
 
End Sub
 
 
Function check(value, arr, column)
' 检查value是否存在于arr的指定列中,不存在返回False，存在返回对应在arr中的序号
Dim r, max_num
 
' 获取数组有效最大序号,减少循环比对
max_num = Application.WorksheetFunction.Count(arr) / 2
 
For r = 1 To max_num
 If value = arr(r, column) Then
 check = r
 Exit Function
 End If
Next r
check = False
End Function