这是一个常用而且经典的例子:根据内容,把一个工作表中的内容,拆分到N个工作表中,并根据内容命名新建的工作表。
¤主要知识点¤
1、影响代码执行闪屏以及提示框的处理:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
2、工作表的新建,命名,删除操作;
3、单元格区域的内容复制方式;
4、IF分支语句和For循环语句的使用;
¤实例¤
新建工作表,把员工信息复制到对应的以部门命名的工作表中。
¤实现代码¤
Option Explicit
Sub 拆分工作表()
Application.DisplayAlerts = False '不显示错误提示框
Application.ScreenUpdating = False '不闪屏
Dim i As Integer '辅助工作表变量
Dim sh As Worksheet
'删除多余的工作表
If Sheets.Count > 1 Then
For i = Worksheets.Count To 2 Step -1
Worksheets(i).Delete
Next i
End If
'对信息表中数据按照部门排序,之后按照部门拆分进新的工作表
Dim irow As Integer '定义一共需要处理的行号
Dim istart As Integer '定位起始行数变量
irow = Range("A" & Rows.Count).End(xlUp).Row '计算一共需要处理的行号
If irow > 2 Then
Range("a3:H" & irow).Sort Range("f2"), xlAscending '对信息区域进行排序,不能含标题
istart = 3
For i = 3 To irow
With Worksheets("员工信息表") '指定活动工作表
If .Range("f" & i).Value <> .Range("f" & i + 1).Value Then '判断是否为同一部门
Worksheets.Add after:=Worksheets(Sheets.Count) '新建工作表
Set sh = Worksheets(Worksheets.Count) '指定工作表给变量
sh.Name = .Range("f" & i).Value '以部门命名工作表
.Range("a1:h2").Copy sh.Range("a1:h2") '复制标题到新建工作表中
.Range("a" & istart & ":h" & i).Copy sh.Range("a3") '复制内容到工作表中
sh.Columns.AutoFit '设置自动列宽
istart = i + 1
End If
End With
Next i
End If
Worksheets("员工信息表").Select '回到第一个工作表
Application.ScreenUpdating = True '恢复闪屏默认设置
Application.DisplayAlerts = True '恢复提示框默认设置
End Sub
Option Explicit
Sub 拆分工作表2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Integer
If Worksheets.Count > 1 Then
For i = Worksheets.Count To 2 Step -1
Worksheets(i).Delete
Next i
End If
Dim irow As Integer
Dim k As Integer
Dim sDep As String
Dim sh As Worksheet
irow = Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To irow
sDep = Worksheets(1).Range("F" & i).Value
On Error Resume Next '遇到错误继续,这里错误主要是未定义的工作表
Set sh = Worksheets(sDep) '这一行如果遇到工作表不存在,就会报错,返回值为err.number <> 0
If Err.Number <> 0 Then '工作表不存在,那么新建工作表,并把标题复制到新建的工作表
Set sh = Worksheets.Add(, Worksheets(1))
sh.Name = sDep
Worksheets(1).Range("A1:h2").Copy sh.Range("A1")
End If
k = sh.Range("A1").CurrentRegion.Rows.Count + 1 '依次复制内容到工作表的行号
'sh.Range("A" & k).Resize(1, 7).Value = Worksheets(1).Range("A" & i).Resize(1, 7).Value '赋值方法
Worksheets(1).Range("A" & i & ":h" & i).Copy sh.Range("A" & k) '复制方法
sh.Columns.AutoFit '列宽自动调整
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub