|
Sub 五十八行一页() '计数2
Dim ar, h, l, n
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
ar = Sheets("数据源表").Range("a1").CurrentRegion
Application.ScreenUpdating = False
Sheets("结果表2").Activate
Range("A:D").Clear
For i = 2 To UBound(ar)
If ar(i, 6) <> "" Then n = n + 1: d(ar(i, 1)) = d(ar(i, 1)) & "," & i
Next i
n = 1: h = 2: l = 1
For Each k In d.keys
dk = Split(d(k), ",")
If l = 4 And h > n * 58 Then
l = 1: n = n + 1
End If
Cells(h, l) = k & " " & "计:" & UBound(dk)
For i = 1 To UBound(dk)
If h > n * 58 Then
Cells(h, 1).Resize(1, 4).Borders(xlEdgeBottom).LineStyle = 1
If l < 4 Then
l = l + 1: h = (n - 1) * 58 + 1
Else
l = 1: n = n + 1
End If
End If
Cells(h + 1, l) = "'" & ar(dk(i), 6)
h = h + 1
Next i
h = h + 1
Next k
Application.ScreenUpdating = True
End Sub
|
|