|
|
Sub 排版()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim br(), cr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("数据源")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空，请先导入数据！": End
ar = .Range("a1:f" & r)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 3)) <> "" Then
d(Trim(ar(i, 3))) = ""
End If
Next i
lh = 1
With Sheets("排版")
.UsedRange.Clear
For Each k In d.keys
n = 0: dc.RemoveAll: kk = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 3)) = k Then
dc(Trim(ar(i, 4))) = ""
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
ReDim cr(1 To UBound(ar), 1 To 3)
kk = 1
cr(kk, 1) = k
For Each kc In dc.keys
kk = kk + 1
cr(kk, 1) = kc
.Cells(kk, lh).Font.Bold = True
For i = 1 To n
If Trim(br(i, 4)) = kc Then
kk = kk + 1
For j = 5 To 6
cr(kk, j - 4) = br(i, j)
Next j
End If
Next i
Next kc
.Cells(1, lh).Resize(kk, 2) = cr
lh = lh + 3
Next k
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-8-30 08:57
楼主