将工作簿中的所有工作表单独保存，原表仍然存在
1.原工作簿：
2.效果显示：
3.VBA代码：
Sub chaifen()
'定义变量sht为工作表
Dim sht As Worksheet
'在所有工作表中遍历一次
For Each sht In Sheets
'工作表复制
sht.Copy
'目前活动的工作表另存为，注意路径的写法
ActiveWorkbook.SaveAs Filename:="D:\C 文件\excel\VBA\day03\CHAIFEN\" & sht.Name & ".xlsx"
'目前活动的工作表关闭
ActiveWorkbook.Close
Next
End Sub
4.知识点：
thisworkbook：指当前VBA代码所处的 workbook
activeworkbook:指当前活跃的workbook
相同点：如果VBA代码只对本身工作薄进行操作，则两者相同；
不同点：如果VBA代码新建或打开了其他工作薄，则往往新建或刚打开的是activeworkbook，可以通过"工作薄名.active"方法激活指定对象。
保留工作薄中不想删除的工作表，其他全部删除
1.原工作薄
2.删除后
3.VBA代码
Sub test()
'删除其他表，保留 绝不能删除 表
Dim sht As Worksheet
Application.DisplayAlerts = False
For Each sht In Sheets
'如果工作表名不等于“决不能删除”
If sht.Name <> "绝不能删除" Then
'将工作表删除
sht.Delete
End If
Next
Application.DisplayAlerts = False
End Sub
4.知识点：
worksheet:单个工作表
worksheets:指定工作薄中所有工作表的集合
Application.DisplayAlerts：如果宏运行时Excel显示特定的警告和信息，则该值为True。如果不想在宏运行时被无穷无尽的提示和警告消息困扰，则将该属性设置为False。
利用空白工作薄控制创建新的工作薄并填写内容
1.VBA代码
Sub chuangjian()
'新建工作薄
Workbooks.Add
'活动工作薄工作表1单元格a1填写内容“这是我自动创建出来的”
ActiveWorkbook.Sheets(1).Range("a1") = "这是我自动创建出来的"
'活动工作薄另存为到指定的文件路径
ActiveWorkbook.SaveAs Filename:="D:\C 文件\excel\VBA\day03\123.xlsx"
End Sub
2.运行效果
3.知识点：
Workbooks:对象是Microsoft Excel应用程序中当前打开的所有Workbook对象的集合，有Close、Add、Open等方法
Workbook:对象是一个Microsoft Excel工作薄，有name、path等属性，有SaveAs等方法，有Open、Activate等事件
Workbooks.Add:新建工作薄，新建的工作薄将成为活动工作薄
利用空白工作薄控制已有的工作薄并填写内容
1.空白的工作表1
2.VBA代码
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'工作薄打开指定路径下的1.xlsx
Workbooks.Open Filename:="D:\C 文件\excel\VBA\day03\1.xlsx"
'活动工作薄工作表1单元格a1填写"又又到此一游"
ActiveWorkbook.Sheets(1).Range("a1") = "又又到此一游"
'活动工作薄保存
ActiveWorkbook.Save
'活动工作薄关闭
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
3.含内容的工作表1
4.知识点：
Application.ScreenUpdating:在Excel的工作表里面数据发生变化后，False禁止实时刷新，True为默认值表示实时更新数据
按部门名称来筛选数据
1.筛选数据
2.VBA代码
Sub chaifen()
Sheet1.Range("a1:F32").AutoFilter Field:=4, Criteria1:="一车间"
End Sub
3.筛选一车间
将数据工作表取消筛选状态
1.筛选状态
2.VBA代码
Sub qxshaixuan()
Sheet1.Range("a1:F32").AutoFilter
End Sub
3.取消筛选
将工作表数据按照部门拆分到部门名称所对应的工作表中-No.01
【注意事项】：分表已经提前做好，需要拷贝数据到分表中
1.如下所示：
按照数据表部门，分别实现以部门名称建立的新表，然后将数据表中部门名称单元格所在行复制到新表中。
2.代码如下：
Sub chaifen1()
'实现功能：将数据表中Range("d" & i)单元格对应的行数据拆分到新表Range("d" & i).value名称的表中
'定义整型数据i,k,j
Dim i,k,j As Integer
'遍历第二个工作表到最后一个工作表
For j = 2 To Sheets.Count
'将工作表数据中的抬头拷贝到其他工作表中去
Sheet1.Range("a1").Resize(1, 6).Copy Sheets(j).Range("a1")
'遍历数据表中第二行到最后一行数据
For i = 2 To Sheets(1).Range("a65536").End(xlUp).Row
'假如数据表单元格("d" & i)单元格对应的值等于表二的名称
If Sheet1.Range("d" & i).Value = Sheets(j).Name Then
'计算表二目前状态下已有多少行数据
k = Sheets(j).Range("a65536").End(xlUp).Row
'将数据表中Range("d" & i)单元格所在整行数据拷贝到数据表中已有行数的下一行
Sheet1.Range("d" & i).EntireRow.Copy Sheets(j).Range("a" & k + 1)
End If
Next
Next
End Sub
3.得到效果：
在分表中出现小数点，暂时还未知原因！
4.知识点：
{1}、在保存含有VBA代码的文件时，在警告提示中选择否，保存格式为xlsm，即可保存成功
{2}、Sheets.Count:获取本工作薄中工作表的总数
{3}、Sheets(Sheets.Count):调用排在最后一位的工作表
{4}、Sheets(Sheets.Count).Name:获取最后一个工作表的名称
将工作表数据按照部门拆分到部门名称所对应的工作表中-No.02
【注意事项】：分表已经提前做好，需要拷贝数据到分表中
【使用方法】：利用excel筛选功能提高效率
1.工作簿表们
2.VBA代码
Sub shaifen()
'定义整型变量i
Dim i As Integer
'从第二张工作表开始遍历
For i = 2 To Sheets.Count
'根据工作表名称来筛选数据工作表
Sheet1.Range("a1:F32").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
'将筛选后的数据工作表复制到第i张工作表的a1单元格
Sheet1.Range("a1:F32").Copy Sheets(i).Range("a1")
Next
'取消数据工作表的筛选
Sheet1.Range("a1:F32").AutoFilter
End Sub
3.执行筛选复制程序后
4.知识点：
Sheets(i).Name:第i张工作表的名称
将工作表数据按照部门拆分到部门名称所对应的工作表中-No.03
【注意事项】：分表未提前做好，需要拷贝数据到分表中
【使用方法】：判断建表结合筛选功能提高拆分表效率
1.数据工作表
2.VBA代码
Sub chaifenshuju()
'定义工作表变量sht
Dim sht As Worksheet
'定义整型变量k,i,j
Dim k, i, j As Integer
Dim irow As Integer '此处定义一个一共多少行的整数值
irow = Sheet1.Range("a65536").End(xlUp).Row
'1此处是建立新工作表的代码
'此处为一个标准遍历写法，需要记住
For i = 2 To irow
'将标记值复位，便于创建未重名新工作表
k = 0
For Each sht In Sheets
If sht.Name = Sheet1.Range("d" & i) Then
k = 1
End If
Next
If k = 0 Then
'按部门名称来创建新工作表
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("d" & i)
End If
Next
'此处是将数据表中的数据按部门进行拷贝到对应部门的工作表中
For j = 2 To Sheets.Count
Sheet1.Range("a1:f" & irow).AutoFilter Field:=4, Criteria1:=Sheets(j).Name
Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")
Next
'数据工作表取消或者选中筛选状态
Sheet1.Range("a1:f" & irow).AutoFilter
End Sub
3.拆分后效果
针对MsgBox以及InputBox的测试
1.测试代码
Sub test()
MsgBox "你好！"
End Sub
【效果展示】
2.测试代码1
Sub test1()
InputBox "你几岁了？"
End Sub
【效果展示】
3.测试代码2
Sub test2()
Dim i As Integer
i = InputBox("你几岁了？")
Sheet1.Range("A1") = i
End Sub
【效果展示】
4.测试代码3
Sub test3()
Dim i As Integer
i = InputBox("你几岁了？")
MsgBox "哦，原来你6岁啦"
End Sub
【效果展示】
5.测试代码4
Sub test4()
Dim i As Integer
i = InputBox("你几岁了？")
MsgBox "哦，原来你" & i & "岁啦"
End Sub
【效果展示】
6.测试代码5
Sub test5()
Range("A1").Select
End Sub
【效果展示】
7.测试代码6
Sub test6()
Cells(4, 1).Select
End Sub
【效果展示】
将工作表数据按照部门拆分到部门名称所对应的工作表中-No.04
【注意事项】：分表未提前做好，需要拷贝数据到分表中
【使用方法】：在NO.03的基础上再升级成最终版本
1.使用控件
2.VBA代码
Sub chaifenshuju()
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 <> "数据" Then
sht1.Delete
End If
Next
End If
'消除提示
Application.DisplayAlerts = False
irow = Sheet1.Range("a65536").End(xlUp).Row
'1此处是建立新工作表的代码
'此处为一个标准遍历写法，需要记住
For i = 2 To irow
k = 0
For Each sht In Sheets
If sht.Name = Sheet1.Cells(i, l) Then
k = 1
End If
Next
If k = 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
End If
Next
'此处是将数据表中的数据按部门进行拷贝到对应部门的工作表中
For j = 2 To Sheets.Count
Sheet1.Range("a1:f" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")
Next
'数据取消或者选中筛选状态
Sheet1.Range("a1:f" & irow).AutoFilter
Sheet1.Select
MsgBox "已经执行完毕！"
End Sub
3.执行效果
4.功能：可以按照列数来进行拆分工作表
按工作表1中单元格内容进行创建新工作表
1.Sheet1
2.VBA代码-No.01
Sub xinjianbiao01()
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("a1")
End Sub
3.VBA代码-No.02
Sub xinjianbiao02()
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Sheet1.Range("a2")
End Sub
4.执行代码后
5.知识点：
Sheets.Add after:=Sheets(Sheets.Count):在最后一张工作表后添加新工作表
按工作表1中单个单元格内容进行创建新工作表
1.工作薄
2.VBA代码
Sub xinjianbiao()
'此处k被定义为整数，默认初始值为0，可以看做是一个开关，判断新表是否能够建立
'此处是针对工作表1单元格a1进行创建新表
Dim sht As Worksheet
Dim k As Integer
'遍历目前已经存在的工作表
For Each sht In Sheets
'如果存在工作表名与制定单元格值相同，则给k赋值1
If sht.Name = Sheet1.Range("a1") Then
k = 1
End If
Next
'如果k值为0，则说明存在工作表名与制定单元格值没有相同
If k = 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("a1")
End If
End Sub
3.执行代码后
4.知识点：
此处设置整数变量k作为标记值，来判断同工作薄中工作表是否有重复名称，如果没有则新建，如果有则不会另外新建
按工作表1中多个单元格内容进行创建新工作表
1.工作表1
2.VBA代码
Sub xinjianbiao1()
'此处k被定义为整数，默认初始值为0，可以看做是一个开关，判断新表是否能够建立
'此处是针对工作表1单元格a1进行创建新表，如果要扩展到a2、a3的话，就需要对a1创建新表的内容循环三次，并稍作修改
'定义工作表变量sht
Dim sht As Worksheet
'定义整型变量k
Dim k As Integer
For i = 1 To 3
'【血泪提醒】记得要恢复标记值k=0,不然一直为1状态，就无法建立新工作表
k = 0
'遍历目前已经存在的工作表
For Each sht In Sheets
'如果存在工作表名与制定单元格值相同，则给k赋值1
If sht.Name = Sheet1.Range("a" & i) Then
k = 1
End If
Next
'如果k值为0，则说明存在工作表名与指定单元格值没有相同
If k = 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("a" & i)
End If
Next
End Sub
3.1月2月3月
将分工作表内容合并到数据工作表中
【提醒】前提已经创建好数据工作表
1.分工作表
2.VBA代码（有待优化）
Sub hebingfenbiao()
'整型变量irow为分工作表的总行数，yrow为数据工作表总行数
Dim irow, yrow As Integer
'定义工作表变量sht
Dim sht As Worksheet
For Each sht In Sheets
irow = sht.Range("a65536").End(xlUp).Row
yrow = Sheets("数据").Range("a65536").End(xlUp).Row
If sht.Name <> "数据" Then
sht.Range("a1:f" & irow).Copy Sheets("数据").Range("a" & yrow + 1)
End If
Next
'数据工作表A1单元格所在整行删除
Sheets("数据").Range("A1").EntireRow.Delete
'最后数据工作表被选中
Sheets("数据").Select
'提示操作已经执行完毕！
MsgBox "已经执行完毕！！！"
End Sub
3.合并后效果
录制宏1，对某一单元格字体的大小进行修改
1.原单元格
2.VBA代码（此代码是录制的）
Sub 宏1()
With Selection.Font
.Name = "宋体"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End Sub
3.执行代码后
4.对录制宏代码进行修改
Sub test1()
Sheet2.Range("A1").Font.Size = 18
End Sub
5.执行后效果
对With的应用
1.未使用With的代码
Sub test()
Sheet2.Range("A1") = 6
Sheet2.Range("A4") = 12
Sheet2.Range("A5") = 8
Sheet2.Range("A7") = 10
End Sub
2.使用With的代码
Sub testxiugai()
With Sheet2
.Range("A1") = 6
.Range("A4") = 12
.Range("A5") = 8
.Range("A7") = 10
End With
End Sub
3.执行后的效果一样
选中工作表中某单元格，则单元格所在整行标记某颜色
手动模式下的整行变色
1.手动模式下整行变色
2.VBA代码
【代码位置】代码在模块2中
Sub ChangeColor()
'所有单元格背景色=无填充颜色
Cells.Interior.Pattern = xlNone
'选择单元格或者多个单元格（选区）所在整行背景颜色填充为黄色
Selection.EntireRow.Interior.Color = 65535
'选择单元格或者多个单元格（选区）所在整列背景颜色填充为黄色
'Selection.EntireColumn.Interior.Color = 65535
End Sub
3.【弊端】在每次点击其他单元格或区域后，必须要点击宏，选择ChangeColor宏执行后才会有效果，不会自动。
自动模式下的整行变色
1.自动模式下的整行变色
2.VBA代码
【代码位置】代码在Sheet1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'工作表选区发生变化，此sub是自动执行，不需要每次点击并选择宏
'此处是事件，如果发生了某事，则会自动执行代码
Cells.Interior.Pattern = xlNone
Selection.EntireRow.Interior.Color = 65535
End Sub
