[已解决]横向追加数据，根据工序汇总产量。

dsmch

分两步走，两次循环完成

1. Sub dsmch()
   
2. Dim arr, brr, crr, d, d2, i&, zf, s&, s2&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheets("交飞明细").Range("A1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 4)
   
7. For i = 2 To UBound(arr)
   
8.     arr(i, 2) = Right(String(8, "0") & arr(i, 2), 8) '8位数的工号足够，根据需要取多个！
   
9.     zf = arr(i, 2) & "," & arr(i, 11) '工号，制单号！
   
10.     If Not d.Exists(zf) Then
    
11.         s = s + 1
    
12.        d(zf) = s
    
13.        brr(s, 1) = arr(i, 2)
    
14.        brr(s, 2) = arr(i, 11)
    
15.        brr(s, 3) = arr(i, 8)
    
16.        brr(s, 4) = arr(i, 14)
    
17.     Else
    
18.        n = d(zf)
    
19.        If InStr(brr(n, 3), arr(i, 8)) = 0 Then brr(n, 3) = brr(n, 3) & "" & arr(i, 8)
    
20.        brr(n, 4) = brr(n, 4) + arr(i, 14)
    
21.     End If
    
22. Next
    
23. ReDim crr(1 To s, 1 To 200)
    
24. d.RemoveAll
    
25. For i = 1 To s
    
26.     d2(brr(i, 1)) = d2(brr(i, 1)) + 1
    
27.     zf = brr(i, 3) & " " & brr(i, 2) & " " & brr(i, 4)
    
28.     If Not d.Exists(brr(i, 1)) Then
    
29.         s2 = s2 + 1
    
30.         d(brr(i, 1)) = s2
    
31.         crr(s2, 1) = brr(i, 1)
    
32.         crr(s2, d2(brr(i, 1)) + 1) = zf
    
33.     Else
    
34.         crr(d(brr(i, 1)), d2(brr(i, 1)) + 1) = zf
    
35.     End If
    
36. Next
    
37. Cells.ClearContents
    
38. Range("a10").Resize(s2, Application.Max(d2.Items) + 1) = crr
    
39. Columns.AutoFit
    
40. End Sub

复制代码

张雄友

dsmch 发表于 2015-3-13 06:45
分两步走，两次循环完成

zf = brr(i, 3) & " " & brr(i, 2) & " " & brr(i, 4) '当只有一个制时不用括号，二个以上制单要括号，怎么表示？

如附件黄色单元格。

张雄友

这样不行的。

    If d2.Keys = 1 Then
    zf = brr(i, 3) & " " & brr(i, 2) & " " & brr(i, 4) '当只有一个制时不用括号，二个以上制单要括号，怎么表示？
    Else
    zf = "(" & brr(i, 3) & ")" & " " & brr(i, 2) & " " & brr(i, 4)
    End If

张雄友

dsmch 发表于 2015-3-13 06:45
分两步走，两次循环完成

还是没有做成功。

dsmch

Sub dsmch()
Dim arr, brr, crr, d, d2, i&, zf, s&, s2&
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Sheets("交飞明细").Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 4)
For i = 2 To UBound(arr)
    arr(i, 2) = Right(String(8, "0") & arr(i, 2), 8) '8位数的工号足够，根据需要取多个！
    zf = arr(i, 2) & "," & arr(i, 11) '工号，制单号！
    If Not d.Exists(zf) Then
        s = s + 1
       d(zf) = s
       brr(s, 1) = arr(i, 2)
       brr(s, 2) = arr(i, 11)
       brr(s, 3) = arr(i, 8)
       brr(s, 4) = arr(i, 14)
    Else
       n = d(zf)
       If InStr(brr(n, 3), arr(i, 8)) = 0 Then brr(n, 3) = brr(n, 3) & "\" & arr(i, 8)
       brr(n, 4) = brr(n, 4) + arr(i, 14)
    End If
Next
ReDim crr(1 To s, 1 To 200)
d.RemoveAll
For i = 1 To s
    d2(brr(i, 1)) = d2(brr(i, 1)) + 1
    If InStr(brr(i, 3), "\") Then brr(i, 3) = "(" & brr(i, 3) & ")"
    zf = brr(i, 3) & " " & brr(i, 2) & " " & brr(i, 4) '当只有一个制时不用括号，二个以上制单要括号，怎么表示？
    If Not d.Exists(brr(i, 1)) Then
        s2 = s2 + 1
        d(brr(i, 1)) = s2
        crr(s2, 1) = brr(i, 1)
        crr(s2, d2(brr(i, 1)) + 1) = zf
    Else
        crr(d(brr(i, 1)), d2(brr(i, 1)) + 1) = zf
    End If
Next
Cells.ClearContents
Range("a10").Resize(s2, Application.Max(d2.Items) + 1) = crr
Columns.AutoFit
End Sub

张雄友

dsmch 发表于 2015-3-15 06:48
Sub dsmch()
Dim arr, brr, crr, d, d2, i&, zf, s&, s2&
Set d = CreateObject("scripting.dictionary") ...

这样写我可能会明白一些：

If InStr(brr(i, 3), "\") > 0 Then brr(i, 3) = "(" & brr(i, 3) & ")"

张雄友

dsmch 发表于 2015-3-15 06:48
Sub dsmch()
Dim arr, brr, crr, d, d2, i&, zf, s&, s2&
Set d = CreateObject("scripting.dictionary") ...

用了二个月，不能满足要求，怎么增加‘姓名与产量之和，这二个项目。谢谢！