Option Explicit
Sub 拆分()
Dim arr, i, j, k, m, n, t
Sheets("拆分").Activate
arr = [a2].CurrentRegion
ReDim brr(1 To UBound(arr, 1) * 10, 1 To 6)
For i = 2 To UBound(arr, 1)
t = Split(arr(i, 5)): n = 0
For j = 0 To UBound(t)
m = m + 1: n = n + 1
brr(m, 1) = m: brr(m, 2) = arr(i, 2) & "-" & n
brr(m, 3) = arr(i, 3): brr(m, 4) = arr(i, 4)
For k = 1 To Len(t(j))
If IsNumeric(Mid(t(j), k, 1)) Then
brr(m, 6) = Mid(t(j), k)
brr(m, 5) = Replace(t(j), brr(m, 6), vbNullString)
Exit For
End If
Next k, j, i
[a14].Resize(m, UBound(brr, 2)) = brr
End Sub
Sub 合并()
Dim arr, i, a, b, m, p, sum
Sheets("合并").Activate
arr = [a2].CurrentRegion.Offset(1)
For i = 1 To UBound(arr, 1) - 1
sum = sum + arr(i, 6)
a = a & "、" & arr(i, 2): b = b & "、" & arr(i, 5)
If arr(i, 3) <> arr(i + 1, 3) Then
m = m + 1
arr(m, 1) = m: arr(m, 2) = Mid(a, 2): arr(m, 3) = arr(i, 3)
arr(m, 4) = arr(p + 1, 4): arr(m, 5) = Mid(b, 2): arr(m, 6) = sum
p = i: sum = 0: a = vbNullString: b = a
End If
Next
[a25].Resize(m, UBound(arr, 2)) = arr
End Sub |