|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 分表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("表1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "表1为空！": End
ar = .Range("a1:g" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
If d(ar(i, 1)) = "" Then
d(ar(i, 1)) = i
Else
d(ar(i, 1)) = d(ar(i, 1)) & "|" & i
End If
End If
Next i
With Sheets("表2")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs >= 22 Then .Rows("22:" & rs).Delete
m = 1
For Each k In d.keys
rr = Split(d(k), "|")
n = 0
ReDim br(1 To UBound(rr) + 1, 1 To 7)
For i = 0 To UBound(rr)
xh = rr(i)
If ar(xh, 1) <> "" Then
n = n + 1
br(n, 1) = n
For j = 2 To 7
br(n, j) = ar(xh, j)
Next j
End If
Next i
If n <= 10 Then
If m = 1 Then
.Cells(m + 3, 2) = k
.Cells(m + 5, 1).Resize(n, UBound(br, 2)) = br
Else
.Rows("1:21").Copy .Cells(m, 1)
.Cells(m + 3, 2) = k
.Range("a" & m + 5 & ":g" & m + 14) = Empty
.Cells(m + 5, 1).Resize(n, UBound(br, 2)) = br
End If
m = m + 21
Else
For i = 1 To n Step 10
If m = 1 Then GoTo 10
.Rows("1:21").Copy .Cells(m, 1)
.Range("a" & m + 5 & ":g" & m + 14) = Empty
10:
.Cells(m + 3, 2) = k
w = m + 4
For s = i To i + 9
If s <= n Then
w = w + 1
For j = 1 To UBound(br, 2)
.Cells(w, j) = br(s, j)
Next j
End If
Next s
m = m + 21
Next i
End If
Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-3-18 11:04
楼主
