|
- Sub 拆分工作表()
- Dim Sht As Worksheet
- Dim arr, m&, n%, Str
- Dim dic As Object
- Set dic = CreateObject("Scripting.Dictionary")
- Application.DisplayAlerts = False
- For Each Sht In ThisWorkbook.Worksheets
- If Sht.Name <> "总表" Then
- Sht.Delete
- End If
- Next
- Application.DisplayAlerts = True
- With Worksheets("总表")
- arr = .Range("A1").CurrentRegion
- For m = 2 To UBound(arr, 1)
- If Not dic.Exists(arr(m, 2)) Then
- Set dic(arr(m, 2)) = .Range("A1:N1")
- End If
- Set dic(arr(m, 2)) = Union(dic(arr(m, 2)), .Range("A" & m & ":N" & m)) '写在此处才能完整的记录所有数据
- Next
- End With
- Application.ScreenUpdating = False
- For Each Str In dic.keys
- With Worksheets.Add(After:=Worksheets(Sheets.Count))
- .Name = WorksheetFunction.Substitute(Str, "/", "-")
- dic(Str).Copy .Range("A1")
- End With
- Next
- Worksheets("总表").Activate
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|