[已解决]（高级！）批量 一对多对应及统计

雄鹰2013

Sub 合并()
Dim arr, brr, crr
Application.ScreenUpdating = False
t = Timer
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion
brr = Sheet2.Range("a1").CurrentRegion
ReDim crr(1 To UBound(arr), 1 To 6)
For i = 2 To UBound(arr)
     d(arr(i, 4)) = d(arr(i, 4)) & "," & i '将缺陷表中条目与行号一一对应
Next i
n = 1
For i = 2 To UBound(brr)
     crr(n, 1) = brr(i, 1) '章节
     crr(n, 2) = brr(i, 2) '条款
     crr(n, 3) = brr(i, 3) '条款内容
     If d(brr(i, 2)) <> "" Then
        ar = Split(d(brr(i, 2)), ",")
        crr(n, 6) = UBound(ar)
        For j = 1 To UBound(ar)
            x = ar(j) '条款所对应的行号
            crr(n, 4) = arr(x, 5) '缺陷
            crr(n, 5) = arr(x, 2) '产品类别
            n = n + 1
        Next j
     Else
        s = 0: Erase ar: n = n + 1
     End If
Next i
Sheet4.Range("a1:e1000").ClearContents
Sheet4.Range("a1").Resize(1, 6) = Array("章节", " 条款 ", "条款内容", "缺陷及问题", "产品类别", "该条款缺陷项计数")
Sheet4.Range("a2").Resize(n, 6) = crr
MsgBox Format(Timer - t, "0.00秒")
Application.ScreenUpdating = True
End Sub