求代码

mrshz

各位大神，求助自定义函数，多谢

duquancai

字典                  

mrshz

不会啊，老师帮一下，感谢

shenjianrong163

楼主的数据是在A3单元格中还是在A列不同单元格中?

mrshz

以一个单元格为例啊

一把小刀闯天下

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

duquancai

mrshz 发表于 2020-3-28 13:20
不会啊，老师帮一下，感谢

周末无事，给一个自定义函数如下，请测试！！！

算了，这个审核太操蛋了！！！

duquancai

详见后面的 函数

mrshz

一把小刀闯天下 发表于 2020-3-28 14:17
Option Explicit

Sub test()

老师，没有合并同类哦，另外 能否 改成 自定义函数，谢谢

duquancai

mrshz 发表于 2020-3-28 16:01
老师，没有合并同类哦，另外 能否 改成 自定义函数，谢谢

自定义函数，我写了一个，一直在审核代码！！！