大神求助按组拆分

东少一羽Q

大神求帮助，将表里 编号 按组 拆分，包括数量拆分，帮忙看看，文字不好描述，详情参阅附件，多谢多谢！

jiangxiaoyun

表示看不明白.....

东少一羽Q

jiangxiaoyun 发表于 2018-7-11 10:26
表示看不明白.....

是不太好理解……描述一下，
拿大组合D_BB01来说，共5个编号BB01,02,03,04,05，被整合有5个小组D_BB01,_1,_2,_3,_4，每组由特定的几个编号构成。
现在要把每个小组共用的 编号 按其所在的小组 进行拆分

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, dic, i, j, t, n, s
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2))
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 3), "+") Then
      t = Split(arr(i, 3), "+")
      For j = 0 To UBound(t)
        If dic.exists(t(j)) Then
          s = dic(t(j)): ReDim Preserve s(UBound(s) + 1)
          s(UBound(s)) = arr(i, 4): dic(t(j)) = s
        Else
          dic(t(j)) = Array(arr(i, 4))
        End If
      Next
    End If
  Next
  For i = 2 To UBound(arr, 1)
    If dic.exists(arr(i, 3)) Then
      t = dic(arr(i, 3))
      For j = 0 To UBound(t)
        n = n + 1: brr(n, 3) = arr(i, 3): brr(n, 4) = t(j)
      Next
    Else
      n = n + 1
      For j = 1 To UBound(arr, 2): brr(n, j) = arr(i, j): Next
    End If
  Next
  With [l2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
    .Offset(-1).Resize(, UBound(arr, 2)) = arr
  End With
End Sub

东少一羽Q

一把小刀闯天下 发表于 2018-7-11 11:30
Option Explicit

Sub test()

厉害，好用好用，多谢大神！！