【VBA教程一】根据要求拆分工作表

1、  把数据粘贴到新建工作簿的sheet1里

2、  按Alt+F11 打开VBA编辑器

3、  点击插入-模块-模块1

4、  双击模块1、把下面的代码复制到模块1后点击保存

5、  把表格保存为带宏文件.xlsm

6、  运行代码Alt+F8 选择【根据要求拆分表】

使用视频教程：

代码如下：

-------------------------------------

Sub 根据要求拆分表()

Dim sht As Worksheet

Dim k, i, j As Integer

Dim irow As Integer '这个说的是一共多少行

Dim l As Integer

l = InputBox("你要关键数据所在的列数是多少", "输入列数的提示框")

'删除无意义的表

Application.DisplayAlerts = False

If Sheets.Count > 1 Then

For Each sht1 In Sheets

If sht1.Name "Sheet1" Then

'把数据粘贴到sheet1表中

sht1.Delete

End If

Next

End If

Application.DisplayAlerts = True

irow = Sheet1.Range("A65536").End(xlUp).Row

'拆分表

For i = 2 To irow

k = 0

For Each sht In Sheets

If sht.Name = Sheet1.Cells(i, l) Then

k = 1

End If

If k = 0 Then

Sheets.Add after:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)

End If

'拷贝数据

Dim rs As Integer

Dim cs As Integer

rs = Sheet1.Range("A1").End(xlDown).Row

cs = Sheet1.Range("A1").End(xlToRight).Column

'Cells(1, 1).Resize(rs, cs).Select

For j = 2 To Sheets.Count

Sheet1.Cells(1, 1).Resize(rs, cs).AutoFilter Field:=l, Criteria1:=Sheets(j).Name

Sheet1.Cells(1, 1).Resize(rs, cs).Copy Sheets(j).Range("a1")

Sheet1.Cells(1, 1).Resize(rs, cs).AutoFilter

Sheet1.Select

MsgBox "已处理完毕"