|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 拆分为工作表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long
Dim d As Object
Dim sh As Worksheet
Set sh = ThisWorkbook.ActiveSheet
Dim rn As Range
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each Sht In Sheets
If Sht.Index > 1 Then
Sht.Delete
End If
Next Sht
Application.DisplayAlerts = True
With sh
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:c" & r)
Set rn = .Rows(3)
End With
For i = 4 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
d(Trim(ar(i, 1))) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 4 To UBound(ar)
If Trim(ar(i, 1)) = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
Set Sht = Sheets.Add(after:=Sheets(Sheets.Count))
With Sht
.Name = k
rn.Copy .[a1]
.[a2].Resize(n, UBound(br, 2)) = br
.[a2].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-4-19 18:58
楼主