知识点：字典，主要是item中可以是union(),并进行复制
======代码如下=======
Sub 在一个工作簿内把总表拆分多个工作表()
Dim title_rng As Range, wb As Object, dic1 As Object
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set dic1 = CreateObject("scripting.dictionary")
With ActiveSheet
On Error Resume Next
col_rng = Application.InputBox("请输入要拆分的列", , "B", , , , , Type:=2)
If col_rng = "" Then MsgBox "取消了": Exit Sub
'On Error GoTo 0
col_num = Cells(1, col_rng).Column
' MsgBox col_num
Set title_rng = .Rows(1)
endrow = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算最后一个工作表的非空行号
endCol = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column '计算最后一个工作表的非空列号
For i = 2 To endrow
s = .Cells(i, col_num).Value
If Not dic1.Exists(s) Then
Set dic1(s) = .Cells(i, 1).Resize(1, endCol)
Else
Set dic1(s) = Union(dic1(s), .Cells(i, 1).Resize(1, endCol))
End If
Debug.Print i
Next i
MsgBox "将拆分出工作表数有：" & dic1.Count
End With
For Each k In dic1.Keys
With ThisWorkbook.Sheets.Add
title_rng.Copy .Range("a1")
dic1(k).Copy .Range("a2")
.Name = k
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
