求助：有一段代码鼓捣不出来，求大侠帮忙晚上，谢谢！

cyh841005@sohu.

Sub 设计师消化分析()
Dim Arr1, Arr2, Arr3, i&, x$, y$, brr(1 To 5000, 1 To 15), n&
Dim d1, d2, d3, k1, k2, k3, t1, t2, t3, ii&, j&, f&, aa, sl, rk, sj
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Sheet4.Activate
[a3:o5000].ClearContents
Arr1 = Sheet1.[a1].CurrentRegion
Arr2 = Sheet5.[a1].CurrentRegion
Arr3 = Sheet7.[a1].CurrentRegion
For i = 2 To UBound(Arr1)
    x = Arr1(i, 3) & "," & Arr1(i, 15) & "," & Arr1(i, 4): y = Arr1(i, 6)
    If d1.Exists(x) = False Then Set d1(x) = CreateObject("Scripting.Dictionary")
    d1(x)(y) = d1(x)(y) & i & ","
Next
k1 = d1.keys: t1 = d1.items: k2 = d2.keys: t2 = d2.items: k3 = d3.keys: t3 = d3.items
For i = 0 To UBound(k1)
    kk = t1(i).keys: tt = t1(i).items: sl = 0: rk = 0
    sj = Split(k1(i), ","): brr(i + 1, 6) = t1(i).Count
    brr(i + 1, 1) = sj(0): brr(i + 1, 2) = sj(1): brr(i + 1, 3) = sj(2): brr(i + 1, 4) = t1(i).Count
    For ii = 0 To UBound(kk)
        tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
        If InStr(tt(ii), ",") Then
            aa = Split(tt(ii), ",")
            For j = 0 To UBound(aa)
                sl = sl + Arr1(aa(j), 11)
                rk = rk + Arr1(aa(j), 12)
            Next
        Else
        End If
    Next
    brr(i + 1, 5) = sl: brr(i + 1, 7) = rk
    brr(i + 1, 12) = brr(i + 1, 7) - brr(i + 1, 9) - brr(i + 1, 11)
    If brr(i + 1, 7) <> 0 Then
        brr(i + 1, 13) = brr(i + 1, 12) / brr(i + 1, 7)
        brr(i + 1, 14) = brr(i + 1, 9) / brr(i + 1, 7): brr(i + 1, 15) = brr(i + 1, 11) / brr(i + 1, 7)
    Else
        brr(i + 1, 13) = ""
        brr(i + 1, 14) = "": brr(i + 1, 15) = ""
    End If
Next
[a3].Resize(i, 15) = brr
End Sub
请大侠帮忙在里面把代码补充一下，数据的提取对应请看截图，汇总的依据是款号，感谢！