从管理数据的角度看,每列数据(文本类)的长度应该一致
Sub dsmch()
Dim arr, brr, d, d2, i&, j&, k&, zf
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 200)
For i = 2 To UBound(arr)
arr(i, 1) = Right(String(6, "0") & arr(i, 1), 6)
zf = arr(i, 1) & "," & arr(i, 3)
If Not d.Exists(arr(i, 1)) Then
h = h + 1
d(arr(i, 1)) = h
brr(h, 1) = arr(i, 1)
End If
If Not d2.Exists(zf) Then
d2(zf) = i
Else
d2(zf) = d2(zf) & "," & i
End If
Next
a = d2.Keys: b = d2.Items: zdl = 0
For i = 1 To h
L = 1
For j = 0 To d2.Count - 1
mc = Split(a(j), ",")(1) '工序名称
If a(j) Like brr(i, 1) & "*" Then
L = L + 1
x = Split(b(j), ",")
p = "": s = 0
For k = 0 To UBound(x)
If InStr(p, arr(x(k), 2)) = 0 Then p = p & "/" & arr(x(k), 2) '制单号去重复!
s = s + arr(x(k), 4)
Next
z = Mid(p, 2)
zf2 = IIf(InStr(z, "/"), "(" & z & ")", z)
brr(i, L) = zf2 & " " & mc & " " & s
End If
Next
If L > zdl Then zdl = L
Next
Range("G18").Resize(h, zdl) = brr
Range("G18").Resize(h, zdl).Borders.LineStyle = xlContinuous
End Sub