|
改一下,- Option Explicit
- Sub 玩玩()
- Dim d As Object
- Dim arr, q As Integer
- Dim rng, sh As Worksheet
- Dim w%, e%, r&, i
- On Error Resume Next
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- For Each sh In Worksheets
- If sh.Name <> "报表" And sh.Name <> "源数据" Then
- sh.Delete
- End If
- Next sh
- With Worksheets("报表")
- arr = .Range("a1").CurrentRegion
- For q = 2 To UBound(arr)
- d(arr(q, 5)) = ""
- Next q
- For Each rng In d.keys
- For w = 2 To UBound(arr)
- If .Cells(w, 5).Value = rng Then
- r = r + 1
- For e = 1 To UBound(arr, 2)
- arr(r, e) = .Cells(w, e).Value
- Next
- End If
- Next
- Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
- sh.Name = rng
- .Rows(1).Copy Worksheets(sh.Name).Range("a1")
- Worksheets(sh.Name).[a2].Resize(r, UBound(arr, 2)) = arr
- r = 0
- Next rng
- End With
- Application.DisplayAlerts = True
- End Sub
复制代码 |
|