[toc]

Excel之VBA拆分工作表

操作效果

此代码可以将工作簿按某一列按关键词拆分，比如全校数据表格，可以按照班级进行拆分，每个班级成为一个表。

• 拆分前

拆分前

• 拆分后

拆分后

操作步骤

1. 开启VBA模块

开启VBA模块

2. 粘贴、运行代码

!粘贴、运行代码](https://upload-images.jianshu.io/upload_images/15454811-b7ec64badaf37967.png?imageMogr2/auto-orient/strip%7CimageView2/2/w/1240)

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