Excel VBA在一个工作簿内把总表拆分多个工作表

知识点：字典，主要是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