|
|
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Dim br()
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空！": End
ar = .Range("a1:h" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
zd = ar(i, 2) & "|" & ar(i, 4)
If Not d.exists(zd) Then Set d(zd) = CreateObject("scripting.dictionary")
d(zd)(i) = ""
End If
Next i
ReDim br(1 To UBound(ar), 1 To 11)
For Each k In d.keys
dc.RemoveAll
hj = 0
For Each kk In d(k).keys
t = dc(ar(kk, 8))
If t = "" Then
km = km + 1
dc(ar(kk, 8)) = km
t = km
br(km, 1) = ar(kk, 2)
br(km, 2) = ar(kk, 1)
br(km, 3) = ar(kk, 4)
br(km, 6) = ar(kk, 8)
End If
br(t, 7) = br(t, 7) + ar(kk, 6)
hj = hj + ar(kk, 6)
Next kk
br(km, 5) = hj
Next k
With Sheets("sheet2")
.Activate
.UsedRange.Offset(2).Borders.LineStyle = 0
.UsedRange.Offset(2).UnMerge
.UsedRange.Offset(2) = Empty
.[a3].Resize(km, UBound(br, 2)) = br
.[a3].Resize(km, UBound(br, 2)).Borders.LineStyle = 1
For i = km + 2 To 3 Step -1
If .Cells(i, 3) = .Cells(i - 1, 3) Then
.Cells(i - 1, 3).Resize(2, 1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
End With
Selection.Merge
.Cells(i - 1, 5).Resize(2, 1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
End With
Selection.Merge
End If
Next i
End With
Set d = Nothing
Set dc = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-19 16:39
楼主
