VBA代碼如下：
Sub 如何將一個Excel工作表的數(shù)據(jù)拆分成多個工作表()
Dim Arr, Rng
As Range, Sht As Worksheet, Dic As Object
Dim k, t,
Str As String, i As Long, lc As Long
Application.ScreenUpdating = False '關(guān)閉屏幕更新
Arr =
Range("A1").CurrentRegion.Value
lc =
UBound(Arr, 2) '求取最后一列的列號
Set Rng =
Rows(1) '標(biāo)題行
Set Dic =
CreateObject("Scripting.Dictionary") '創(chuàng)建字典
For i = 2 To
UBound(Arr)
Str = Arr(i, 3) '訂單號，關(guān)鍵字
If Not Dic.Exists(Str) Then '如果字典沒有關(guān)鍵字
Set Dic(Str) = Cells(i, 1).Resize(, lc) '把當(dāng)前行裝入到字典中
Else '否則(字典中存在關(guān)鍵字)
Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc))
'把行連合起來
End If
Next
k = Dic.Keys
'字典關(guān)鍵字集合
t =
Dic.Items '字典項(xiàng)目集合
On Error
Resume Next
With
Sheets
For i = 0 To Dic.Count - 1 '循環(huán)關(guān)鍵字的個數(shù)
Set Sht = .Item(k(i)) '給變量賦值(工作表名為關(guān)鍵字)
If Sht Is Nothing Then '該工作表不存在則插入一個空工作表
.Add(After:=.Item(.Count)).Name = k(i)
'新建的工作表將置于所有工作表之后，并命名為關(guān)鍵字
Set Sht = ActiveSheet '活動工作表給變量
Else '否則
Sht.Cells.Clear '清除工作中所有內(nèi)容和格式
End If
Rng.Copy Sht.Range("A1") '把標(biāo)題寫入第一行
t(i).Copy Sht.Range("A2") '寫入其他內(nèi)容
Sht.Cells.EntireColumn.AutoFit '自動調(diào)整全工作表單元格的列寬
Set Sht = Nothing '變量處于初始狀態(tài)
Next
End
With
Sheets(1).Activate '第1個工作表處于激活狀態(tài)
Application.ScreenUpdating = True '打開屏幕更新 |
