Option Explicit
Sub test()
Dim arr, i, j, t, sum(1), p, m, s
arr = Range("a3:a" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
For i = 1 To UBound(arr, 1) - 1
ReDim brr(10, 1 To 3)
t = Split(arr(i, 1), Chr(10))
For j = 0 To UBound(t)
brr(j, 1) = Split(Split(t(j), "(")(1), ")")(0)
brr(j, 3) = Split(Split(t(j), "[")(1), "]")(0)
Next
sum(0) = 0: p = 0: m = 0
For j = 0 To UBound(t)
sum(1) = sum(1) + brr(j, 3)
If brr(j, 1) <> brr(j + 1, 1) Then
brr(m, 2) = j - p + 1: brr(m, 3) = sum(1)
sum(0) = sum(0) + sum(1)
m = m + 1: sum(1) = 0: p = j + 1
End If
Next
For j = 0 To m - 1
s = s & vbNewLine & j + 1 & "、" & brr(j, 1) & "(" & brr(j, 2) & ")" _
& "[" & brr(j, 3) & "]--" & Format(brr(j, 3) / sum(0), "0%")
Next
arr(i, 1) = Mid(s, 3): s = vbNullString
Next
[b3].Resize(UBound(arr, 1) - 1) = arr
End Sub |