本帖最后由 hasyh2008 于 2022-5-9 12:09 编辑
Sub TQ()
Dim Rs%, I%, Dic
Dim Arr(), Ky(), It()
Rs = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Arr = Sheet1.Range("A3:B" & Rs)
Set Dic = CreateObject("scripting.dictionary")
For I = 1 To UBound(Arr)
Dic(Arr(I, 1)) = Dic(Arr(I, 1)) & vbLf & Arr(I, 2)
Next I
Ky = Dic.keys
It = Dic.Items
With Sheet2
.Range("A5:B10000") = ""
For I = 1 To UBound(Ky) + 1
.Range(Cells(I * 3 + 2, 1), Cells(I * 3 + 4, 1)).Merge
.Range(Cells(I * 3 + 2, 2), Cells(I * 3 + 4, 2)).Merge
.Cells(I * 3 + 2, 1) = Ky(I - 1)
.Cells(I * 3 + 2, 2) = It(I - 1)
Next I
End With
End Sub