|
楼主 |
发表于 2024-5-16 14:04
|
显示全部楼层
Sub ykcbf()
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook
Set sh = ws.Sheets("Sheet1")
bt = 1: col = 3
For Each sht In Sheets
If sht.Name <> sh.Name Then sht.Delete
Next
arr = sh.UsedRange
For i = bt + 1 To UBound(arr)
s = arr(i, col)
If Not d.Exists(s) Then
Set d(s) = CreateObject("scripting.dictionary")
End If
d(s)(i) = Application.Index(arr, i)
Next i
For Each k In d.Keys
sh.Copy after:=Sheets(Sheets.Count)
Set sht = Sheets(Sheets.Count)
m = d(k).Count
With sht
.Name = k
.UsedRange.Offset(m + bt).Clear
.DrawingObjects.Delete
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).items, 1)
Columns(3).NumberFormatLocal = "0_);[红色](0)"
End With
Next k
sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
|
|