[toc]
Excel之VBA拆分工作表
操作效果
此代碼可以將工作簿按某一列按關鍵詞拆分，比如全校數據表格，可以按照班級進行拆分，每個班級成為一個表。
- 拆分前
拆分前
- 拆分后
拆分后
操作步驟
- 開啟VBA模塊
開啟VBA模塊
- 粘貼悲伶、運行代碼
Sub 拆分表()
Dim sht As Worksheet
Dim irow As Integer
Dim i, j, k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Integer
Dim sht0 As Worksheet
Dim sht1 As Worksheet
on error resume next
Set sht0 = ActiveSheet
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
For Each sht1 In Sheets
If sht1.Name <> sht0.Name Then
sht1.Delete
End If
Next
End If
l = Application.InputBox("您要按哪列分住涉？A列為1麸锉，B列為2……", "輸入數字", , , , , , 1)
n = Application.InputBox("篩選條件在第幾行", "輸入數字", , , , , , 1)
irow = sht0.Range("a10000").End(xlUp).Row
For i = n + 1 To irow
k = 0
For Each sht In Sheets
If sht0.Cells(i, l) = sht.Name Then 'l為篩選第幾列
k = 1
End If
Next
If k = 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sht0.Cells(i, l)
End If
Next
For j = 2 To Sheets.Count
Sheets(1).Select
Cells(1, n).Select
Selection.AutoFilter
sht0.Range("a1:cz" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name 'l為篩選第幾列
sht0.Range("a1:cz" & irow).Copy Sheets(j).Range("a1")
Sheets(j).Cells.RowHeight = 20 '20為行高
Sheets(1).Select
Cells(1, n).Select
Selection.AutoFilter
Next
sht0.Select
Application.DisplayAlerts = True
End Sub
