- Sub grf()
- Dim ar, r, d, x, l, k, br()
- Set d = CreateObject("scripting.dictionary")
- With Sheets("数据")
- r = .Cells(2 ^ 16, 1).End(3).Row
- ar = .Range("a1:g" & r)
- End With
- ReDim br(1 To r, 1 To 6)
- For x = 1 To r
- st = ar(x, 1) & ar(x, 2) & ar(x, 3) & ar(x, 4)
- ss = ar(x, 5) & "," & ar(x, 6) & ","
- If Not d.Exists(st) Then
- k = k + 1: d(st) = k
- For l = 1 To 4
- br(k, l) = ar(x, l)
- Next
- br(k, 5) = ar(x, 7)
- br(k, 6) = ss & ar(x, 7)
- Else
- p = d(st)
- br(p, 5) = br(p, 5) + ar(x, 7)
- q = InStr(br(p, 6), ss)
- If q > 0 Then
- a = Val(Mid(br(p, 6), q + Len(ss)))
- b = Val(Mid(br(p, 6), q + Len(ss))) + ar(x, 7)
- br(p, 6) = Replace(br(p, 6), ss & a, ss & b)
- Else
- br(p, 6) = br(p, 6) & "" & ss & ar(x, 7)
- End If
- End If
- Next
- Range("a1").Resize(k, 6) = br
- Range("a1").Resize(k, 6).Borders.LineStyle = xlContinuous
- End Sub
复制代码 |