|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub test()
Dim arr, sht, i, j, m
Call doevent(False)
For Each sht In Sheets
If sht.Name <> "Sheet1" Then sht.Delete
Next
arr = Sheets("sheet1").[a1].CurrentRegion.Offset(1).Resize(, 7)
Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 4)
For i = 1 To UBound(arr, 1) - 1
m = m + 1
For j = 1 To UBound(arr, 2)
arr(m, j) = arr(i, j)
Next
If arr(i, 4) <> arr(i + 1, 4) Then
Sheets.Add
With ActiveSheet
.Name = arr(i, 4)
.[a2].Resize(m, UBound(arr, 2)) = arr
Sheets("sheet1").[a1].Resize(1, UBound(arr, 2)).Copy [a1]
.[a1].Resize(m + 1, UBound(arr, 2)).Borders.LineStyle = xlContinuous
End With
m = 0
End If
Next
Call doevent(True)
End Sub
Function bsort(arr, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If StrComp(arr(j, key), arr(j + 1, key), vbTextCompare) = 1 Then
For k = left To right
t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
Next
End If
Next j, i
End Function
Function doevent(flag As Boolean)
With Application
.DisplayAlerts = flag
.ScreenUpdating = flag
End With
End Function |
评分
-
2
查看全部评分
-
|